variants vocab for ADTs

core/classes/tuple/parser/parser.factor

@@ -33,7 +33,7 @@ ERROR: invalid-slot-name name ;
 : parse-long-slot-name ( -- spec )
     [ scan , \ } parse-until % ] { } make ;
 
-: parse-slot-name ( string/f -- ? )
+: parse-slot-name-delim ( end-delim string/f -- ? )
     #! This isn't meant to enforce any kind of policy, just
     #! to check for mistakes of this form:
     #!
@@ -43,12 +43,18 @@ ERROR: invalid-slot-name name ;
     {
         { [ dup not ] [ unexpected-eof ] }
         { [ dup { ":" "(" "<" "\"" "!" } member? ] [ invalid-slot-name ] }
-        { [ dup ";" = ] [ drop f ] }
+        { [ 2dup = ] [ drop f ] }
         [ dup "{" = [ drop parse-long-slot-name ] when , t ]
-    } cond ;
+    } cond nip ;
+
+: parse-tuple-slots-delim ( end-delim -- )
+    dup scan parse-slot-name-delim [ parse-tuple-slots-delim ] [ drop ] if ;
+
+: parse-slot-name ( string/f -- ? )
+    ";" swap parse-slot-name-delim ;
 
 : parse-tuple-slots ( -- )
-    scan parse-slot-name [ parse-tuple-slots ] when ;
+    ";" parse-tuple-slots-delim ;
 
 : parse-tuple-definition ( -- class superclass slots )
     CREATE-CLASS

extra/variants/authors.txt

@@ -0,0 +1 @@
+Joe Groff

extra/variants/summary.txt

@@ -0,0 +1 @@
+Syntax and combinators for manipulating algebraic data types

extra/variants/variants-tests.factor

@@ -0,0 +1,21 @@
+! (c)2009 Joe Groff bsd license
+USING: kernel math tools.test variants ;
+IN: variants.tests
+
+VARIANT: list
+    nil
+    cons: { { first object } { rest list } }
+    ;
+
+[ t ] [ nil list? ] unit-test
+[ t ] [ 1 nil <cons> list? ] unit-test
+[ f ] [ 1 list? ] unit-test
+
+: list-length ( list -- length )
+    {
+        { nil  [ 0 ] }
+        { cons [ nip list-length 1 + ] }
+    } match ;
+
+[ 4 ]
+[ 5 6 7 8 nil <cons> <cons> <cons> <cons> list-length ] unit-test

extra/variants/variants.factor

@@ -0,0 +1,59 @@
+! (c)2009 Joe Groff 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 ;
+
+M: variant-class initial-value*
+    dup members [ no-initial-value ]
+    [ nip first dup word? [ initial-value* ] unless ] 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 ;
+
+: 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 ;
+
+: parse-variant-tuple-member ( name -- member )
+    create-class-in tuple
+    "{" expect
+    [ "}" parse-tuple-slots-delim ] { } make
+    3array ;
+
+: parse-variant-member ( name -- member )
+    ":" ?tail [ parse-variant-tuple-member ] [ create-class-in ] if ;
+
+: parse-variant-members ( -- members )
+    [ scan dup ";" = not ]
+    [ parse-variant-member ] produce nip ;
+
+SYNTAX: VARIANT:
+    CREATE-CLASS
+    parse-variant-members
+    define-variant-class ;
+
+MACRO: unboa ( class -- )
+    <wrapper> \ boa [ ] 2sequence [undo] ;
+
+GENERIC# (match-branch) 1 ( class quot -- class quot' )
+
+M: singleton-class (match-branch)
+    \ drop prefix ;
+M: object (match-branch)
+    over \ unboa [ ] 2sequence prepend ;
+
+: ?class ( object -- class )
+    dup word? [ class ] unless ;
+
+MACRO: match ( branches -- )
+    [ dup callable? [ first2 (match-branch) 2array ] unless ] map
+    [ \ dup \ ?class ] dip \ case [ ] 4sequence ;
+