stomp.cli: simplify

[factor.git] / extra / variants / variants.factor

diff --git a/extra/variants/variants.factor b/extra/variants/variants.factor
index 5cb786afde568cb9a7489ded970b84b20395593d..cdb38dabe449552b2fb15a9fc0fc0987189e811d 100644 (file)
--- a/extra/variants/variants.factor
+++ b/extra/variants/variants.factor
@@ -1,26 +1,34 @@
-! (c)2009 Joe Groff bsd license
+! Copyright (C) 2009 Joe Groff.
+! See https://factorcode.org/license.txt for BSD license.
 USING: accessors arrays classes classes.mixin classes.parser
 classes.singleton classes.tuple classes.tuple.parser
 classes.union combinators inverse kernel lexer macros make
 parser quotations sequences slots splitting words ;
 IN: variants
 
-PREDICATE: variant-class < mixin-class "variant" word-prop ;
+PREDICATE: variant-class < mixin-class "variant?" word-prop ;
 
 M: variant-class initial-value*
-    dup members [ no-initial-value ]
-    [ nip first dup word? [ initial-value* ] unless ] if-empty ;
+    class-members [ f f ] [
+        first dup word? [ t ] [ initial-value* ] if
+    ] if-empty ;
 
 : define-tuple-class-and-boa-word ( class superclass slots -- )
     pick [ define-tuple-class ] dip
-    dup name>> "<" ">" surround create-in swap define-boa-word ;
+    dup name>> "<" ">" surround create-word-in swap define-boa-word ;
 
 : define-variant-member ( member -- class )
     dup array? [ first3 pick [ define-tuple-class-and-boa-word ] dip ] [ dup define-singleton-class ] if ;
 
-: define-variant-class ( class members -- )
-    [ [ define-mixin-class ] [ t "variant" set-word-prop ] [ ] tri ] dip
-    [ define-variant-member swap add-mixin-instance ] with each ;
+: define-variant-class ( class -- )
+    [ define-mixin-class ] [ t "variant?" set-word-prop ] bi ;
+
+: define-variant-class-member ( class member -- )
+    define-variant-member swap add-mixin-instance ;
+
+: define-variant-class-members ( class members -- )
+    [ dup define-variant-class ] dip
+    [ define-variant-class-member ] with each ;
 
 : parse-variant-tuple-member ( name -- member )
     create-class-in tuple
@@ -32,18 +40,23 @@ M: variant-class initial-value*
     ":" ?tail [ parse-variant-tuple-member ] [ create-class-in ] if ;
 
 : parse-variant-members ( -- members )
-    [ scan dup ";" = not ]
+    [ scan-token dup ";" = not ]
     [ parse-variant-member ] produce nip ;
 
 SYNTAX: VARIANT:
-    CREATE-CLASS
+    scan-new-class
     parse-variant-members
-    define-variant-class ;
+    define-variant-class-members ;
 
-MACRO: unboa ( class -- )
+SYNTAX: VARIANT-MEMBER:
+    scan-word
+    scan-token parse-variant-member
+    define-variant-class-member ";" expect ;
+
+MACRO: unboa ( class -- quot )
     <wrapper> \ boa [ ] 2sequence [undo] ;
 
-GENERIC# (match-branch) 1 ( class quot -- class quot' )
+GENERIC#: (match-branch) 1 ( class quot -- class quot' )
 
 M: singleton-class (match-branch)
     \ drop prefix ;
@@ -51,9 +64,8 @@ M: object (match-branch)
     over \ unboa [ ] 2sequence prepend ;
 
 : ?class ( object -- class )
-    dup word? [ class ] unless ;
+    dup word? [ class-of ] unless ;
 
-MACRO: match ( branches -- )
+MACRO: match ( branches -- quot )
     [ dup callable? [ first2 (match-branch) 2array ] unless ] map
     [ \ dup \ ?class ] dip \ case [ ] 4sequence ;
-