.
.
; """ }
-{ $description "Defines " { $snippet "class-name" } " as a union of the following " { $link singleton-class } " and " { $link tuple-class } " definitions. Each " { $snippet "singleton" } " word is defined as a " { $snippet "singleton-class" } ", and each " { $snippet "tuple" } " word is defined aas a " { $snippet "tuple-class" } " with the given set of " { $snippet "slot" } "s, using the same syntax for slot specifiers as " { $link POSTPONE: TUPLE: } ". Typed tuple slots can recursively reference the variant " { $snippet "class-name" } " being defined. For " { $snippet "tuple" } " types, a " { $link boa } " constructor word " { $snippet "<tuple>" } " is defined as well." }
+{ $description "Defines " { $snippet "class-name" } " as a union of the following " { $link singleton-class } " and " { $link tuple-class } " definitions. Each " { $snippet "singleton" } " word is defined as a " { $snippet "singleton-class" } ", and each " { $snippet "tuple" } " word is defined as a " { $snippet "tuple-class" } " with the given set of " { $snippet "slot" } "s, using the same syntax for slot specifiers as " { $link POSTPONE: TUPLE: } ". Typed tuple slots can recursively reference the variant " { $snippet "class-name" } " being defined. For " { $snippet "tuple" } " types, a " { $link boa } " constructor word " { $snippet "<tuple>" } " is defined as well." }
{ $examples { $code """
USING: kernel variants ;
IN: scratchpad
;
""" } } ;
+HELP: VARIANT-MEMBER:
+{ $description "Defines a new member of a variant class without restricting such definitions to a single statement or source file. The variant class should be listed first, and the class member should follow." }
+{ $examples { $code """
+USING: kernel variants ;
+IN: scratchpad
+
+VARIANT: list ;
+
+VARIANT-MEMBER: list nil
+VARIANT-MEMBER: list cons: { { first object } { rest list } }
+""" } } ;
+
HELP: match
{ $values { "branches" array } }
{ $description "Dispatches on the type of the value on the top of the stack. If the type is a " { $link singleton-class } ", the corresponding quotation is called with the underlying stack unchanged. If the type is a " { $link tuple-class } ", the tuple slots are pushed onto the stack by order of arguments." }
"The " { $vocab-link "variants" } " vocabulary provides syntax and combinators for defining and manipulating algebraic data types."
{ $subsections
POSTPONE: VARIANT:
+ POSTPONE: VARIANT-MEMBER:
variant-class
match
} ;
[ 4 ]
[ 5 6 7 8 nil <cons> <cons> <cons> <cons> list-length ] unit-test
+
+
+VARIANT: list2 ;
+VARIANT-MEMBER: list2 nil2
+VARIANT-MEMBER: list2 cons2: { { first object } { rest list2 } }
+
+[ t ] [ nil2 list2? ] unit-test
+[ t ] [ 1 nil2 <cons2> list2? ] unit-test
+[ f ] [ 1 list2? ] unit-test
+
+: list2-length ( list2 -- length )
+ {
+ { nil2 [ 0 ] }
+ { cons2 [ nip list2-length 1 + ] }
+ } match ;
+
+[ 4 ]
+[ 5 6 7 8 nil2 <cons2> <cons2> <cons2> <cons2> list2-length ] unit-test
: 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
SYNTAX: VARIANT:
CREATE-CLASS
parse-variant-members
- define-variant-class ;
+ define-variant-class-members ;
+
+SYNTAX: VARIANT-MEMBER:
+ scan-word
+ scan parse-variant-member
+ define-variant-class-member ;
MACRO: unboa ( class -- )
<wrapper> \ boa [ ] 2sequence [undo] ;