modern: working on arity/decorators again

extra/modern/manifest/manifest.factor

@@ -65,6 +65,13 @@ ERROR: key-exists val key assoc existing-value ;
 : add-ucolon-arity ( syntax-forms parser tag -- syntax-forms ) pick ucolon-arities>> checked-set-at ;
 : add-named-section-arity ( syntax-forms parser tag -- syntax-forms ) pick named-section-arities>> checked-set-at ;
 
+: lookup-arity ( form syntax-forms -- n/f )
+    over upper-colon? [
+        [ first >string but-last ] [ ucolon-arities>> ] bi* at
+    ] [
+        2drop f
+    ] if ;
+
 ! One syntax-forms per vocab-root
 : core-syntax-forms ( -- obj )
     <syntax-forms>
@@ -211,8 +218,10 @@ ERROR: key-exists val key assoc existing-value ;
         nip like nip
     ] if ; inline
 
+! : apply-arity ( seq syntax-forms -- seq' )
+!    '[ 
 
-: apply-decorators ( seq forms -- seq' )
+: apply-decorators ( seq syntax-forms -- seq' )
     '[ nip dup slice? [ >string _ rdecorators>> at ] [ drop f ] if ] monotonic-split ;
 
 : upper-colon>form ( seq -- form )
@@ -225,6 +234,33 @@ GENERIC: upper-colon>definitions ( form -- seq )
 
 : form>definitions ( obj -- obj' )
     {
-        { [ dup ?first upper-colon? ] [ upper-colon>definitions ] }
+        { [ dup upper-colon? ] [ upper-colon>definitions ] }
         [ ]
     } cond ;
+
+GENERIC#: fixup-arity 1 ( obj syntax-forms -- seq )
+
+![[
+ERROR: closing-tag-required obj ;
+M: upper-colon fixup-arity
+    dup tag>> janky-arities ?at [
+        '[ _ swap [ any-comment? not ] cut-nth-match swap ] change-payload
+        swap 2array
+        dup first f >>closing-tag drop
+        dup first [ ] [ underlying>> ] [ payload>> last-underlying-slice ] tri force-merge-slices >>underlying drop
+        ! dup first " ;" >>closing-tag drop
+    ] [
+        drop
+        ! dup closing-tag>> [ B closing-tag-required ] unless
+        ! dup closing-tag>> [ " ;" >>closing-tag ] unless
+    ] if ;
+
+M: less-than-literal fixup-arity
+    [ [ fixup-arity ] map ] change-payload ;
+
+M: object fixup-arity ;
+
+: postprocess-modern ( seq -- seq' )
+    collapse-decorators [ fixup-arity ] map flatten ;
+
+]]

extra/modern/out/out.factor

@@ -47,7 +47,7 @@ DEFER: map-literals
 DEFER: map-literals
 : map-literal ( obj quot: ( ..a obj -- ..a obj' ) -- obj )
     over section? [
-        [ second ] dip map-literals
+        [ second ] dip map-literals concat
     ] [
         call
     ] if ; inline recursive
@@ -55,6 +55,23 @@ DEFER: map-literals
 : map-literals ( seq quot: ( ..a obj -- ..a obj' ) -- seq' )
     '[ _ map-literal ] map ; inline recursive
 
+![[
+! ": foo ; <PRIV : bar ; PRIV>" string>literals [ B upper-colon? ] filter-literals >strings
+
+DEFER: filter-literals
+: filter-literal ( obj quot: ( ..a obj -- ..a obj' ) -- obj )
+    over section? [
+        B [ second ] dip filter-literals
+    ] [
+        call
+    ] if ; inline recursive
+
+: filter-literals ( seq quot: ( ..a obj -- ..a obj' ) -- seq' )
+    { } pick length over [ (selector-as) [ each ] dip ] 2curry
+    [ dip like ] 3curry
+    '[ _ filter-literal ] filter ; inline recursive
+]]
+
 DEFER: map-literals!
 : map-literal! ( obj quot: ( obj -- obj' ) -- obj )
     over { [ array? ] [ ?first section-open? ] } 1&& [

extra/modern/tools/tools.factor

@@ -11,7 +11,7 @@ IN: modern.tools
         [
             { [ upper-colon? ] [ first "USING:" sequence= ] } 1&&
         ] filter
-        [ second >strings ] map
+        [ second >strings ] map concat
     ] assoc-map ;
 
 ! Needs filter-literals
@@ -24,7 +24,7 @@ IN: modern.tools
         ] [
           drop f
         ] if
-      ] map-literals harvest concat harvest
+      ] map-literals harvest concat
     ] assoc-map ;
 
 : vocabs>graph ( vocabs -- graph )