diff --git a/extra/modern/manifest/manifest.factor b/extra/modern/manifest/manifest.factor index 74648e7832..7dd90ccda6 100644 --- a/extra/modern/manifest/manifest.factor +++ b/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 ) @@ -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 ; + +]] \ No newline at end of file diff --git a/extra/modern/out/out.factor b/extra/modern/out/out.factor index 19dd4b0891..011dcb983d 100644 --- a/extra/modern/out/out.factor +++ b/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 ; " 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&& [ diff --git a/extra/modern/tools/tools.factor b/extra/modern/tools/tools.factor index 8fece4ed9f..e087411cdb 100644 --- a/extra/modern/tools/tools.factor +++ b/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 )