wrap.strings: allow breaking long words

diff --git a/basis/wrap/strings/strings-tests.factor b/basis/wrap/strings/strings-tests.factor
index 60ad39964c3052351ab72f5e6bce16e9aeacf1b6..42fbc81691549159c28c8703ab8d4f9e8a0bbf84 100644 (file)
--- a/basis/wrap/strings/strings-tests.factor
+++ b/basis/wrap/strings/strings-tests.factor
@@ -72,3 +72,9 @@ word wrap."
 { "Hello" } [ "\nHello\n" 10 wrap-string ] unit-test
 
 { " > > > " } [ "" 70 " > > > " wrap-indented-string ] unit-test
+
+{ "aaaa\naaaa\naa" } [
+    t break-long-words? [
+        10 CHAR: a <string> 4 wrap-string
+    ] with-variable
+] unit-test

diff --git a/basis/wrap/strings/strings.factor b/basis/wrap/strings/strings.factor
index 5de604d73b86dd01ef6c220b1f5f1c96625eff92..9ec0a9e9f31302dd642d55f4eb9bf2b378ab694d 100644 (file)
--- a/basis/wrap/strings/strings.factor
+++ b/basis/wrap/strings/strings.factor
@@ -1,18 +1,26 @@
 ! Copyright (C) 2009 Daniel Ehrenberg
 ! See https://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences splitting strings wrap ;
+USING: arrays grouping kernel math namespaces sequences
+splitting strings wrap ;
 IN: wrap.strings
 
+INITIALIZED-SYMBOL: break-long-words? [ f ]
+
 <PRIVATE
 
-: wrap-split-line ( string -- elements )
-    dup [ " \t" member? not ] find drop 0 or
-    [ f swap ] [ cut ] if-zero
-    " \t" split harvest [ dup length 1 <element> ] map!
-    swap [ 0 over length <element> prefix ] when* ;
+: wrap-split-line ( string width -- elements )
+    [
+        dup [ " \t" member? not ] find drop 0 or
+        [ f swap ] [ cut ] if-zero
+        " \t" split harvest break-long-words? get
+    ] dip '[
+        [ _ group [ dup length 1 <element> ] map ] map concat
+    ] [
+        [ dup length 1 <element> ] map
+    ] if swap [ 0 over length <element> prefix ] when* ;
 
-: wrap-split-lines ( string -- elements-lines )
-    split-lines [ wrap-split-line ] map! ;
+: wrap-split-lines ( string width -- elements-lines )
+    [ split-lines ] dip '[ _ wrap-split-line ] map! ;
 
 : join-elements ( wrapped-lines -- lines )
     [ join-words ] map! ;
@@ -20,7 +28,7 @@ IN: wrap.strings
 PRIVATE>
 
 : wrap-lines ( string width -- newlines )
-    [ wrap-split-lines ] dip '[ _ wrap join-elements ] map! concat ;
+    [ wrap-split-lines ] keep '[ _ wrap join-elements ] map! concat ;
 
 : wrap-string ( string width -- newstring )
     wrap-lines join-lines ;