Make mixins smarter, fix interactor

core/classes/classes-tests.factor

@@ -157,7 +157,7 @@ UNION: redefine-bug-2 redefine-bug-1 quotation ;
 [ t ] [ quotation redefine-bug-2 class< ] unit-test
 [ redefine-bug-2 ] [ fixnum quotation class-or ] unit-test
 
-"IN: temporary USE: math UNION: redefine-bug-1 bignum ;" eval
+[ ] [ "IN: temporary USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test
 
 [ t ] [ bignum redefine-bug-1 class< ] unit-test
 [ f ] [ fixnum redefine-bug-2 class< ] unit-test
@@ -173,3 +173,35 @@ FORGET: forget-class-bug-1
 FORGET: forget-class-bug-2
 
 [ t ] [ integer dll class-or interned? ] unit-test
+
+DEFER: mixin-forget-test-g
+
+[ ] [
+    {
+        "USING: sequences ;"
+        "IN: temporary"
+        "MIXIN: mixin-forget-test"
+        "INSTANCE: sequence mixin-forget-test"
+        "GENERIC: mixin-forget-test-g ( x -- y )"
+        "M: mixin-forget-test mixin-forget-test-g ;"
+    } "\n" join <string-reader> "mixin-forget-test"
+    parse-stream drop
+] unit-test
+
+[ { } ] [ { } mixin-forget-test-g ] unit-test
+[ H{ } mixin-forget-test-g ] unit-test-fails
+
+[ ] [
+    {
+        "USING: hashtables ;"
+        "IN: temporary"
+        "MIXIN: mixin-forget-test"
+        "INSTANCE: hashtable mixin-forget-test"
+        "GENERIC: mixin-forget-test-g ( x -- y )"
+        "M: mixin-forget-test mixin-forget-test-g ;"
+    } "\n" join <string-reader> "mixin-forget-test"
+    parse-stream drop
+] unit-test
+
+[ { } mixin-forget-test-g ] unit-test-fails
+[ H{ } ] [ H{ } mixin-forget-test-g ] unit-test

core/classes/classes.factor

@@ -239,8 +239,6 @@ M: word uncache-class drop ;
 : uncache-classes ( assoc -- )
     [ drop uncache-class ] assoc-each ;
 
-GENERIC: update-methods ( class -- )
-
 PRIVATE>
 
 : define-class-props ( members superclass metaclass -- assoc )
@@ -265,7 +263,7 @@ PRIVATE>
         uncache-classes
         dupd (define-class)
     ] keep cache-classes
-    r> [ update-methods ] [ drop ] if ;
+    r> [ changed-class ] [ drop ] if ;
 
 GENERIC: class ( object -- class ) inline
 

core/classes/mixin/mixin.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2004, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: classes classes.union words kernel sequences ;
+USING: classes classes.union words kernel sequences
+definitions prettyprint.backend ;
 IN: classes.mixin
 
 PREDICATE: union-class mixin-class "mixin" word-prop ;
@@ -19,11 +20,48 @@ M: mixin-class reset-class
         { } redefine-mixin-class
     ] if ;
 
+TUPLE: check-mixin-class mixin ;
+
+: check-mixin-class ( mixin -- mixin )
+    dup mixin-class? [
+        \ check-mixin-class construct-boa throw
+    ] unless ;
+
+: if-mixin-member? ( class mixin true false -- )
+    >r >r check-mixin-class 2dup members memq? r> r> if ; inline
+
+: change-mixin-class ( class mixin quot -- )
+    [ members swap bootstrap-word ] swap compose keep
+    swap redefine-mixin-class ; inline
+
 : add-mixin-instance ( class mixin -- )
-    dup mixin-class? [ "Not a mixin class" throw ] unless
-    2dup members memq? [
-        2drop
-    ] [
-        [ members swap bootstrap-word add ] keep swap
-        redefine-mixin-class
-    ] if ;
+    [ 2drop ] [ [ add ] change-mixin-class ] if-mixin-member? ;
+
+: remove-mixin-instance ( class mixin -- )
+    [ [ swap remove ] change-mixin-class ] [ 2drop ] if-mixin-member? ;
+
+! Definition protocol implementation ensures that removing an
+! INSTANCE: declaration from a source file updates the mixin.
+TUPLE: mixin-instance loc class mixin ;
+
+: <mixin-instance> ( class mixin -- definition )
+    { set-mixin-instance-class set-mixin-instance-mixin }
+    mixin-instance construct ;
+
+M: mixin-instance where mixin-instance-loc ;
+
+M: mixin-instance set-where set-mixin-instance-loc ;
+
+M: mixin-instance synopsis*
+    \ INSTANCE: pprint-word
+    dup mixin-instance-class pprint-word
+    mixin-instance-mixin pprint-word ;
+
+M: mixin-instance definer drop \ INSTANCE: f ;
+
+M: mixin-instance definition drop f ;
+
+M: mixin-instance forget
+    dup mixin-instance-class
+    swap mixin-instance-mixin
+    remove-mixin-instance ;

core/definitions/definitions-docs.factor

@@ -14,7 +14,7 @@ $nl
 { $subsection uses }
 "When a definition is changed, all definitions which depend on it are notified via a hook:"
 { $subsection redefined* }
-"Definitions must implement a few operations used for printing them in human and computer-readable form:"
+"Definitions must implement a few operations used for printing them in source form:"
 { $subsection synopsis* }
 { $subsection definer }
 { $subsection definition } ;

core/definitions/definitions.factor

@@ -44,7 +44,10 @@ M: object redefined* drop ;
 : delete-xref ( defspec -- )
     dup unxref crossref get delete-at ;
 
+GENERIC: update-methods ( class -- )
+
 SYMBOL: changed-words
+SYMBOL: changed-classes
 SYMBOL: old-definitions
 SYMBOL: new-definitions
 
@@ -91,12 +94,19 @@ TUPLE: no-compilation-unit word ;
     [ no-compilation-unit ] unless*
     set-at ;
 
+: changed-class ( class -- )
+    dup changed-classes get
+    [ no-compilation-unit ] unless*
+    set-at ;
+
 : with-compilation-unit ( quot -- )
     [
         H{ } clone changed-words set
+        H{ } clone changed-classes set
         <definitions> new-definitions set
         <definitions> old-definitions set
         [
+            changed-classes get keys [ update-methods ] each
             changed-words get keys recompile-hook get call
         ] [ ] cleanup
     ] with-scope ; inline

core/prettyprint/prettyprint-tests.factor

@@ -148,7 +148,7 @@ unit-test
     {
         "USING: io kernel sequences words ;"
         "IN: temporary"
-        ": retain-stack-layout"
+        ": retain-stack-layout ( x -- )"
         "    dup stream-readln stream-readln"
         "    >r [ define ] map r>"
         "    define ;"
@@ -162,7 +162,7 @@ unit-test
     {
         "USING: kernel math sequences strings ;"
         "IN: temporary"
-        ": soft-break-layout"
+        ": soft-break-layout ( x y -- ? )"
         "    over string? ["
         "        over hashcode over hashcode number="
         "        [ sequence= ] [ 2drop f ] if"
@@ -204,7 +204,7 @@ unit-test
     {
         "USING: io kernel parser ;"
         "IN: temporary"
-        ": string-layout-test"
+        ": string-layout-test ( error -- )"
         "    \"Expected \" write dup unexpected-want expected>string write"
         "    \" but got \" write unexpected-got expected>string print ;"
     } ;
@@ -256,7 +256,7 @@ unit-test
 : another-narrow-test
     {
         "IN: temporary"
-        ": another-narrow-layout"
+        ": another-narrow-layout ( -- obj )"
         "    H{"
         "        { 1 2 }"
         "        { 3 4 }"
@@ -275,8 +275,10 @@ unit-test
 : class-see-test
     {
         "IN: temporary"
-        "TUPLE: class-see-layout bar ;"
-        "GENERIC: class-see-layout"
+        "TUPLE: class-see-layout ;"
+        ""
+        "IN: temporary"
+        "GENERIC: class-see-layout ( x -- y )"
         ""
         "USING: temporary ;"
         "M: class-see-layout class-see-layout ;"

core/prettyprint/prettyprint.factor

@@ -249,14 +249,17 @@ M: word see-class* drop ;
 M: builtin-class see-class*
     drop "! Built-in class" comment. ;
 
-: see-all ( seq -- ) natural-sort [ nl see ] each ;
+: see-all ( seq -- )
+    natural-sort [ nl see ] each ;
 
 : see-implementors ( class -- seq )
     dup implementors [ 2array ] curry* map ;
 
 : see-class ( class -- )
     dup class? [
-        dup seeing-word dup see-class*
+        [
+            dup seeing-word dup see-class*
+        ] with-use nl
     ] when drop ;
 
 : see-methods ( generic -- seq )
@@ -264,10 +267,13 @@ M: builtin-class see-class*
     [ 2array ] curry map ;
 
 M: word see
-    [
-        dup see-class
-        dup class? over symbol? and not [ dup (see) ] when
-    ] with-use nl
+    dup see-class
+    dup class? over symbol? not and [
+        nl
+    ] when
+    dup class? over symbol? and not [
+        [ dup (see) ] with-use nl
+    ] when
     [
         dup class? [ dup see-implementors % ] when
         dup generic? [ dup see-methods % ] when

core/syntax/syntax.factor

@@ -134,7 +134,11 @@ IN: bootstrap.syntax
         CREATE-CLASS define-mixin-class
     ] define-syntax
 
-    "INSTANCE:" [ scan-word scan-word add-mixin-instance ] define-syntax
+    "INSTANCE:" [
+        location >r
+        scan-word scan-word 2dup add-mixin-instance
+        <mixin-instance> r> remember-definition
+    ] define-syntax
 
     "PREDICATE:" [
         scan-word

extra/ui/gestures/gestures.factor

@@ -115,7 +115,7 @@ drag-timer construct-empty drag-timer set-global
 
 : start-drag-timer ( -- )
     hand-buttons get-global empty? [
-        drag-timer get-global 100 100 add-timer
+        drag-timer get-global 100 300 add-timer
     ] when ;
 
 : stop-drag-timer ( -- )

extra/ui/tools/interactor/interactor.factor

@@ -11,9 +11,13 @@ IN: ui.tools.interactor
 TUPLE: interactor
 history output
 continuation quot busy?
-use
 help ;
 
+: interactor-use ( interactor -- seq )
+    use swap
+    interactor-continuation continuation-name
+    assoc-stack ;
+
 : init-caret-help ( interactor -- )
     dup editor-caret 100 <delay> swap set-interactor-help ;
 
@@ -67,11 +71,13 @@ M: interactor model-changed
     t over set-interactor-busy?
     interactor-continuation schedule-thread-with ;
 
+: clear-input ( interactor -- ) gadget-model clear-doc ;
+
 : interactor-finish ( interactor -- )
     [ editor-string ] keep
     [ interactor-input. ] 2keep
     [ add-interactor-history ] keep
-    gadget-model clear-doc ;
+    clear-input ;
 
 : interactor-eof ( interactor -- )
     dup interactor-busy? [
@@ -108,9 +114,6 @@ M: interactor stream-read
 M: interactor stream-read-partial
     stream-read ;
 
-: save-use ( interactor -- )
-    use get swap set-interactor-use ;
-
 : go-to-error ( interactor error -- )
     dup parse-error-line 1- swap parse-error-col 2array
     over set-caret
@@ -122,7 +125,7 @@ M: interactor stream-read-partial
 
 : try-parse ( lines interactor -- quot/error/f )
     [
-        >r parse-lines-interactive r> save-use
+        drop parse-lines-interactive
     ] [
         >r f swap set-interactor-busy? drop r>
         dup delegate unexpected-eof? [ drop f ] when
@@ -136,19 +139,18 @@ M: interactor stream-read-partial
     } cond ;
 
 M: interactor stream-read-quot
-    [ save-use ] keep
-    [ interactor-yield ] keep over quotation? [
-        drop
-    ] [
-        [ handle-interactive ] keep swap
-        [ interactor-finish ] [ nip stream-read-quot ] if
-    ] if ;
+    [ interactor-yield ] keep {
+        { [ over not ] [ drop ] }
+        { [ over callable? ] [ drop ] }
+        { [ t ] [
+            [ handle-interactive ] keep swap
+            [ interactor-finish ] [ nip stream-read-quot ] if
+        ] }
+    } cond ;
 
 M: interactor pref-dim*
     0 over line-height 4 * 2array swap delegate pref-dim* vmax ;
 
-: clear-input gadget-model clear-doc ;
-
 interactor "interactor" f {
     { T{ key-down f f "RET" } evaluate-input }
     { T{ key-down f { C+ } "k" } clear-input }

extra/ui/tools/listener/listener-tests.factor

@@ -1,7 +1,7 @@
 USING: continuations documents ui.tools.interactor
 ui.tools.listener hashtables kernel namespaces parser sequences
 timers tools.test ui.commands ui.gadgets ui.gadgets.editors
-ui.gadgets.panes vocabs words tools.test.ui ;
+ui.gadgets.panes vocabs words tools.test.ui slots.private ;
 IN: temporary
 
 timers [ init-timers ] unless
@@ -13,16 +13,12 @@ timers [ init-timers ] unless
 [ ] [ <listener-gadget> "listener" set ] unit-test
 
 "listener" get [
-    { "kernel" } [ vocab-words ] map
-    "listener" get listener-gadget-input set-interactor-use
-
     [ "dup" ] [ \ dup "listener" get word-completion-string ] unit-test
 
-    [ "USE: words word-name" ]
-    [ \ word-name "listener" get word-completion-string ] unit-test
+    [ "USE: slots.private slot" ]
+    [ \ slot "listener" get word-completion-string ] unit-test
 
     <pane> <interactor> "i" set
-    f "i" get set-interactor-use
 
     [ t ] [ "i" get interactor? ] unit-test
 

extra/ui/tools/listener/listener.factor

@@ -97,9 +97,9 @@ M: listener-operation invoke-command ( target command -- )
     listener-gadget-input user-input ;
 
 : quot-action ( interactor -- lines )
-    dup control-value swap
-    2dup add-interactor-history
-    select-all ;
+    dup control-value
+    dup "\n" join pick add-interactor-history
+    swap select-all ;
 
 TUPLE: stack-display ;