Refactor basis/wrap to have a more flexible API

diff --git a/basis/wrap/wrap-tests.factor b/basis/wrap/wrap-tests.factor
new file mode 100644 (file)
index 0000000..b2d1876
--- /dev/null
+++ b/basis/wrap/wrap-tests.factor
@@ -0,0 +1,48 @@
+IN: wrap.tests
+USING: tools.test wrap multiline sequences ;
+    
+[
+    {
+        {
+            T{ word f 1 10 f }
+            T{ word f 2 10 f }
+            T{ word f 3 2 t }
+        }
+        {
+            T{ word f 4 10 f }
+            T{ word f 5 10 f }
+        }
+    }
+] [
+    {
+        T{ word f 1 10 f }
+        T{ word f 2 10 f }
+        T{ word f 3 2 t }
+        T{ word f 4 10 f }
+        T{ word f 5 10 f }
+    } 35 wrap [ { } like ] map
+] unit-test
+
+[
+    <" This is a
+long piece
+of text
+that we
+wish to
+word wrap.">
+] [
+    <" This is a long piece of text that we wish to word wrap."> 10
+    wrap-string
+] unit-test
+    
+[
+    <"   This is a
+  long piece
+  of text
+  that we
+  wish to
+  word wrap.">
+] [
+    <" This is a long piece of text that we wish to word wrap."> 12
+    "  " wrap-indented-string
+] unit-test
\ No newline at end of file

diff --git a/basis/wrap/wrap.factor b/basis/wrap/wrap.factor
index 87a870d75d771421e6abdf58bfdf1dbf2eb2809c..8e4e2753a866d423e46bd8535036bdd9db9d252f 100644 (file)
--- a/basis/wrap/wrap.factor
+++ b/basis/wrap/wrap.factor
@@ -1,32 +1,60 @@
-USING: sequences kernel namespaces make splitting math math.order ;
+USING: sequences kernel namespaces make splitting
+math math.order fry assocs accessors ;
 IN: wrap
 
-! Very stupid word wrapping/line breaking
-! This will be replaced by a Unicode-aware method,
-! which works with variable-width fonts
+! Word wrapping/line breaking -- not Unicode-aware
+
+TUPLE: word key width break? ;
+
+C: <word> word
+
+<PRIVATE
 
 SYMBOL: width
 
-: line-chunks ( string -- words-lines )
-    "\n" split [ " \t" split harvest ] map ;
+: break-here? ( column word -- ? )
+    break?>> not [ width get > ] [ drop f ] if ;
+
+: find-optimal-break ( words -- n )
+    [ 0 ] dip [ [ width>> + dup ] keep break-here? ] find drop nip ;
 
-: (split-chunk) ( words -- )
-    -1 over [ length + 1+ dup width get > ] find drop nip
-    [ 1 max cut-slice swap , (split-chunk) ] [ , ] if* ;
+: (wrap) ( words -- )
+    dup find-optimal-break
+    [ 1 max cut-slice [ , ] [ (wrap) ] bi* ] [ , ] if* ;
 
-: split-chunk ( words -- lines )
-    [ (split-chunk) ] { } make ;
+: intersperse ( seq elt -- seq' )
+    [ '[ _ , ] [ , ] interleave ] { } make ;
 
-: join-spaces ( words-seqs -- lines )
-    [ [ " " join ] map ] map concat ;
+: split-lines ( string -- words-lines )
+    string-lines [
+        " \t" split harvest
+        [ dup length f <word> ] map
+        " " 1 t <word> intersperse
+    ] map ;
 
-: broken-lines ( string width -- lines )
+: join-words ( wrapped-lines -- lines )
+    [
+        [ break?>> ]
+        [ trim-head-slice ]
+        [ trim-tail-slice ] bi
+        [ key>> ] map concat
+    ] map ;
+
+: join-lines ( strings -- string )
+    "\n" join ;
+
+PRIVATE>
+
+: wrap ( words width -- lines )
     width [
-        line-chunks [ split-chunk ] map join-spaces
+        [ (wrap) ] { } make
     ] with-variable ;
 
-: line-break ( string width -- newstring )
-    broken-lines "\n" join ;
+: wrap-lines ( lines width -- newlines )
+    [ split-lines ] dip '[ _ wrap join-words ] map concat ;
+
+: wrap-string ( string width -- newstring )
+    wrap-lines join-lines ;
 
-: indented-break ( string width indent -- newstring )
-    [ length - broken-lines ] keep [ prepend ] curry map "\n" join ;
+: wrap-indented-string ( string width indent -- newstring )
+    [ length - wrap-lines ] keep '[ _ prepend ] map join-lines ;

diff --git a/basis/xml/writer/writer.factor b/basis/xml/writer/writer.factor
index 146e67e70f77d989fe4d3e9f71e167fdc9f3ee6f..a713790973282a7566c230107979210affb17940 100755 (executable)
--- a/basis/xml/writer/writer.factor
+++ b/basis/xml/writer/writer.factor
@@ -69,7 +69,7 @@ M: string write-xml
     escape-string xml-pprint? get [\r
         dup [ blank? ] all?\r
         [ drop "" ]\r
-        [ nl 80 indent-string indented-break ] if\r
+        [ nl 80 indent-string wrap-indented-string ] if\r
     ] when write ;\r
 \r
 : write-tag ( tag -- )\r