From e83100b7596af6ecb1bab2ad2514028d8e45f93b Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 3 Nov 2019 15:22:59 -0600
Subject: [PATCH] modern: wip

---
 extra/modern/compiler/compiler.factor | 10 ++++++++--
 extra/modern/manifest/manifest.factor | 27 +++++++++++++++++++++-----
 extra/modern/out/out.factor           | 28 +++++++++++++++++++++++++++
 3 files changed, 58 insertions(+), 7 deletions(-)

diff --git a/extra/modern/compiler/compiler.factor b/extra/modern/compiler/compiler.factor
index b3c077acdb..01656a92f1 100644
--- a/extra/modern/compiler/compiler.factor
+++ b/extra/modern/compiler/compiler.factor
@@ -38,17 +38,23 @@ TUPLE: escaped-object < lexed name payload ;
 CONSTRUCTOR: <escaped-object> escaped-object ( tokens -- obj ) ;
 
 TUPLE: section < lexed tag payload ;
-CONSTRUCTOR: <section> section ( tokens -- obj ) ;
+CONSTRUCTOR: <section> section ( tokens -- obj )
+    dup second >>payload ;
 
 TUPLE: named-section < lexed tag name payload ;
 CONSTRUCTOR: <named-section> named-section ( tokens -- obj ) ;
 
-TUPLE: upper-colon < lexed tag payload ;
+
+TUPLE: upper-colon < lexed tag payload decorators ;
 CONSTRUCTOR: <upper-colon> upper-colon ( tokens -- obj )
     ! put this in the fixup-arity/decorators instead
     dup tokens>> first but-last-slice >>tag ;
     ! dup tokens>> [ first but-last-slice >>tag ] [ second >>payload ] bi ;
 
+: add-upper-colon-decorator ( upper-colon obj -- upper-colon )
+    [ '[ _ suffix ] change-decorators ]
+    [ '[ _ suffix ] change-tokens ] bi ;
+
 TUPLE: lower-colon < lexed tag payload ;
 CONSTRUCTOR: <lower-colon> lower-colon ( tokens -- obj ) ;
 
diff --git a/extra/modern/manifest/manifest.factor b/extra/modern/manifest/manifest.factor
index 9bbcdc4456..57f24e1678 100644
--- a/extra/modern/manifest/manifest.factor
+++ b/extra/modern/manifest/manifest.factor
@@ -221,16 +221,33 @@ ERROR: key-exists val key assoc existing-value ;
     ] if ; inline
 
 
+ERROR: not-a-decorator obj ;
+
 GENERIC#: apply-decorators2 1 ( seq syntax-forms -- seq' )
 
 M: array apply-decorators2
-    '[ nip dup slice? [ >string _ rdecorators>> at ] [ drop f ] if ] monotonic-split ;
+    ! monotonoic-split doesn't iterate if only one item
+    over length 1 = [
+        '[ dup section? [ _ apply-decorators2 ] when ] map
+    ] [
+        dup '[
+            nip dup slice? [
+                >string _ rdecorators>> ?at [ not-a-decorator ] unless
+            ] [
+                dup section? [
+                    [ _ apply-decorators2 ] change-payload drop f
+                ] [
+                    drop f
+                ] if
+            ] if
+        ] monotonic-split
+    ] if ;
 
 M: section apply-decorators2
-    '[ _ swap apply-decorators2 ] change-payload ;
+    '[ _ apply-decorators2 ] change-payload ;
 
-: apply-decorators ( seq syntax-forms -- seq' )
-    '[ [ nip dup slice? [ >string _ rdecorators>> at ] [ drop f ] if ] monotonic-split ] map-literals ;
+! : apply-decorators ( seq syntax-forms -- seq' )
+!    '[ [ nip dup slice? [ >string _ rdecorators>> at ] [ drop f ] if ] monotonic-split ] map-literals ;
 
 : upper-colon>form ( seq -- form )
     [ first "syntax" lookup-word ] [ ] bi 2array ;
@@ -318,4 +335,4 @@ M: object fixup-arity drop ;
 
 : fixup-parse ( seq -- seq' )
     core-syntax-forms
-    [ fixup-arity ] [ apply-decorators ] bi ;
+    [ fixup-arity ] [ apply-decorators2 ] bi ;
diff --git a/extra/modern/out/out.factor b/extra/modern/out/out.factor
index 011dcb983d..89e283ba81 100644
--- a/extra/modern/out/out.factor
+++ b/extra/modern/out/out.factor
@@ -85,6 +85,34 @@ DEFER: map-literals!
 : map-literals! ( seq quot: ( obj -- obj' ) -- seq )
     '[ _ map-literal! ] map! ; inline recursive
 
+![[
+GENERIC: split-to-sections ( seq -- seq' )
+
+M: array split-to-sections ( seq -- seq' )
+    dup length 1 = [
+        [ dup section? [ split-to-sections ] when ] map
+    ] [
+        [
+            [ nip dup section? [ split-to-sections ] when drop ]
+            [ [ section? ] either? not ] 2bi
+        ] monotonic-split
+    ] if ;
+
+M: section split-to-sections ( seq -- seq' )
+    [ split-to-sections ] change-payload ;
+
+
+GENERIC#: map-sections* 1 ( seq quot -- seq' )
+
+M: section map-sections* ( seq quot -- seq' )
+    '[ _ ] change-payload ; inline recursive
+
+M: array map-sections* ( seq quot -- seq' )
+    dup '[ dup section? [ _ map-sections* ] [ @ ] if ] map ; inline recursive
+
+: map-sections ( seq quot -- seq' )
+    [ split-to-sections ] dip map-sections* ; inline
+]]
 
 : write-modern-string ( seq -- string )
     [ write-literal ] with-string-writer ; inline