Fixed bugs in linewrapping

1 files changed, 39 insertions, 16 deletions

diff --git a/server/src/Thermoprint/Server/Printer/Generic.hs b/server/src/Thermoprint/Server/Printer/Generic.hs
index 2945dd0..24150cf 100644
--- a/server/src/Thermoprint/Server/Printer/Generic.hs
+++ b/server/src/Thermoprint/Server/Printer/Generic.hs
@@ -139,10 +139,17 @@ initDoc space = Doc { lines          = Seq.empty
                     }
 
 breakLine :: Doc -> Doc
-breakLine doc@(Doc{..}) = doc { remainingSpace = space, lines = lines |> currentLine, currentLine = return () }
+breakLine doc@(Doc{..}) = doc { remainingSpace = space
+                              , lines = lines |> currentLine
+                              , currentLine = return ()
+                              }
   
 renderDoc :: Doc -> Put
-renderDoc Doc{..} = intersperse' (newls' 1) id lines >> currentLine
+renderDoc Doc{..} = intersperse' (newls' 1) id lines'
+  where
+    lines'
+      | remainingSpace == space = lines
+      | otherwise               = lines |> currentLine
 
 renderBlock :: Block -> State Doc ()
 renderBlock (VSpace n)   = sequence_ . genericReplicate n $ modify' breakLine
@@ -153,19 +160,35 @@ renderLine :: Line -> State Doc ()
 renderLine (HSpace n)    = modify' insertSpace
   where
     insertSpace doc@(Doc{..})
-      | remainingSpace > n = doc { remainingSpace = remainingSpace - n, currentLine = currentLine >> (sequence_ $ genericReplicate n $ encode' " ") }
-      | remainingSpace == n = doc { remainingSpace = space, currentLine = return (), lines = lines |> currentLine }
-      | otherwise = doc { remainingSpace = space, lines = lines |> currentLine, currentLine = return (), overflows = overflows + 1 }
+      | remainingSpace > n = doc { remainingSpace = remainingSpace - n
+                                 , currentLine = currentLine >> (sequence_ $ genericReplicate n $ encode' " ")
+                                 }
+      | remainingSpace == n = breakLine doc
+      | otherwise = breakLine $ doc { overflows = overflows + 1 }
 renderLine (JuxtaPos xs) = mapM_ renderLine xs
-renderLine word          = modify' $ insertWord
+renderLine (cotext . Line -> word) = modify' $ insertWord
   where
-    insertWord doc@(Doc{..})
-      | remainingSpace > length = doc { remainingSpace = remainingSpace - (length + 1), currentLine = currentLine >> word'' }
-      | remainingSpace == length = doc { remainingSpace = space, lines = lines |> (currentLine >> word''), currentLine = return () }
-      | space >= length = doc { remainingSpace = space - length, lines = lines |> currentLine, currentLine = word'' }
-      | length `div` space == 0 = doc { remainingSpace = space, lines = (lines |> currentLine) <> (cs |> c), currentLine = return (), overflows = overflows + (toEnum $ Seq.length cs) }
-      | otherwise = doc { remainingSpace = space - (length `div` space), lines = (lines |> currentLine) <> cs, currentLine = c, overflows = overflows + (toEnum $ Seq.length cs) }
-    word' = cotext (Line word)
-    word'' = encode' $ TL.unpack $ word'
-    length = toInteger $ TL.length word'
-    (cs :> c) = viewr . Seq.fromList . map (encode' . TL.unpack) $ TL.chunksOf (fromInteger length) word'
+    insertWord doc
+      | TL.null wordTail = checkBreak $ doc'
+      | otherwise = checkBreak $ doc' { remainingSpace = space doc' - (wordTail' `mod` space doc')
+                                      , lines = (lines doc' |> currentLine doc') <> cs
+                                      , currentLine = c
+                                      , overflows = overflows doc' + 1 + (toInteger $ Seq.length cs)
+                                      }
+      where
+        (wordInit, wordTail) = TL.splitAt (fromInteger $ remainingSpace doc) word
+        wordInit' = toInteger $ TL.length wordInit
+        wordTail' = toInteger $ TL.length wordTail
+        doc' = insertInit doc
+        insertInit doc@(Doc{..}) = doc { remainingSpace = remainingSpace - wordInit'
+                                       , currentLine = currentLine >> encode'' wordInit
+                                       }
+        (cs :> c) = viewr . Seq.fromList . map encode'' $ TL.chunksOf (fromInteger $ space doc) wordTail
+        checkBreak doc@(Doc{..})
+          | remainingSpace == 0 = doc { remainingSpace = space
+                                      , lines = lines |> currentLine
+                                      , currentLine = return ()
+                                      }
+          | otherwise = doc
+    encode'' = encode' . TL.unpack
+