Working prototype of Generic

3 files changed, 83 insertions, 36 deletions

diff --git a/server/src/Thermoprint/Server/Printer/Generic.hs b/server/src/Thermoprint/Server/Printer/Generic.hs
index b993eaf..2c88b55 100644
--- a/server/src/Thermoprint/Server/Printer/Generic.hs
+++ b/server/src/Thermoprint/Server/Printer/Generic.hs
@@ -1,6 +1,8 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module Thermoprint.Server.Printer.Generic
        ( genericPrint
@@ -13,7 +15,7 @@ import Thermoprint.Server.Printer
 import System.FileLock
 import System.IO
 
-import Data.Sequence (Seq, (|>), (<|), ViewL(..), viewl)
+import Data.Sequence (Seq, (|>), (<|), ViewL(..), viewl, ViewR(..), viewr)
 import qualified Data.Sequence as Seq
 
 import qualified Data.ByteString.Lazy as Lazy (ByteString)
@@ -22,14 +24,18 @@ import qualified Data.ByteString.Lazy.Char8 as CLBS
 
 import qualified Data.Text.Lazy as Lazy (Text)
 import qualified Data.Text.Lazy as TL
+
+import qualified Data.Text as T
        
 import Data.Encoding
 import Data.Encoding.CP437
+import Data.Binary.Put
 import Data.Word
 
 import Control.Monad
 import Control.Monad.Reader
 import Control.Monad.Trans.State
+import Control.Monad.Logger
 import Control.Monad.IO.Class
 
 import Control.Monad.Trans.Resource
@@ -40,58 +46,55 @@ import Control.Monad.Catch
 
 import Data.Foldable
 
-import Data.List (genericReplicate, intercalate)
+import Data.List (genericReplicate, genericLength, intercalate)
+
+import Data.Monoid
 
 import Data.Int (Int64)
 
-import Prelude hiding (mapM_, sequence_)
+import Prelude hiding (mapM_, sequence_, lines)
 
 genericPrint :: FilePath -> PrinterMethod
 genericPrint path = PM $ genericPrint' path
 
-genericPrint' :: (MonadIO m, MonadMask m) => FilePath -> Printout -> m (Maybe PrintingError)
-genericPrint' path = flip catches handlers . withLockedFile path . print
+genericPrint' :: (MonadIO m, MonadMask m, MonadLogger m) => FilePath -> Printout -> m (Maybe PrintingError)
+genericPrint' path = flip catches handlers . withFile path . print
   where
-    print printout handle = liftIO $ runReaderT (bracket_ initialize (render printout) finalize) handle >> return Nothing
+    withFile path f = flip withEx f $ mkAcquire (openFile path WriteMode >>= (\h -> h <$ hSetBuffering h NoBuffering)) hClose
     handlers = [ Handler $ return . Just . IOError . (show :: IOException -> String)
                , Handler $ return . Just . EncError
                , Handler $ return . Just
                ]
-
-withLockedFile :: (MonadIO m, MonadMask m) => FilePath -> (Handle -> m a) -> m a
-withLockedFile path f = withEx (lockedFile path) (f . snd)
-
-lockedFile :: FilePath -> Acquire (FileLock, Handle)
-lockedFile f = mkAcquire ((,) <$> lockFile f Exclusive <*> openFile f WriteMode) (\(lock, h) -> () <$ hClose h <* unlockFile lock)
-
-type Render = ReaderT Handle IO ()
+    print printout handle = $(logDebug) (T.pack $ show printout') >> liftIO (LBS.hPutStr handle printout' >> return Nothing)
+      where
+        printout' = runPut $ initialize >> render printout >> finalize
 
 encode' :: ByteSink m => String -> m ()
 encode' = encode CP437
 
-width :: Int64
+width :: Integer
 width = 32
 
 esc :: Word8
 esc = 27
 
-escSequence :: [Word8] -> Render
+escSequence :: [Word8] -> Put
 escSequence = mapM_ pushWord8 . (esc:)
 
-initialize :: Render
+initialize :: Put
 initialize = replicateM_ 2 $ escSequence [64]
 
 newl :: Lazy.ByteString
-newl = "\r\n"
+newl = encodeLazyByteString CP437 "\n"
 
 newls :: Integer -> Lazy.ByteString
 newls i = mconcat $ genericReplicate i newl
 
-newls' :: Integer -> Render
+newls' :: Integer -> Put
 newls' = mapM_ pushWord8 . LBS.unpack . newls
 
-finalize :: Render -- TODO: adjust this to produce proper padding
-finalize = newls' 2
+finalize :: Put
+finalize = newls' 3 >> encode' " " >> newls' 1
 
 intersperse :: b -> (a -> b) -> Seq a -> Seq b
 intersperse _ _ (viewl -> EmptyL)                 = Seq.empty
@@ -101,16 +104,59 @@ intersperse b f (viewl -> x :< xs)                = f x <| b <| intersperse b f
 intersperse' :: Monad m => m b -> (a -> m b) -> Seq a -> m ()
 intersperse' b f = sequence_ . intersperse b f
 
-render :: Printout -> Render
-render = intersperse' (newls' 1) renderPar
+render :: Printout -> Put
+render = intersperse' (newls' 2) renderPar
 
-renderPar :: Paragraph -> Render
+renderPar :: Paragraph -> Put
 renderPar = mapM_ renderChunk
   where
     renderChunk (Raw bs)       = mapM_ pushWord8 $ LBS.unpack bs
-    renderChunk (Cooked block) = renderBlock block
-
-renderBlock :: Block -> Render
-renderBlock (VSpace n)   = newls' n
-renderBlock (NewlSep xs) = intersperse' (newls' 1) renderBlock xs
-renderBlock (Line x)     = undefined
+    renderChunk (Cooked block) = renderDoc $ execState (renderBlock block) (initDoc width)
+
+data Doc = Doc
+  { lines :: Seq Put
+  , currentLine :: Put
+  , space :: Integer
+  , remainingSpace :: Integer
+  , overflows :: Integer
+  }
+
+initDoc :: Integer -> Doc
+initDoc space = Doc { lines          = Seq.empty
+                    , currentLine    = return ()
+                    , space          = space
+                    , remainingSpace = space
+                    , overflows      = 0
+                    }
+
+breakLine :: Doc -> Doc
+breakLine doc@(Doc{..}) = doc { remainingSpace = space, lines = lines |> currentLine, currentLine = return () }
+  
+renderDoc :: Doc -> Put
+renderDoc Doc{..} = intersperse' (newls' 1) id lines >> currentLine
+
+renderBlock :: Block -> State Doc ()
+renderBlock (VSpace n)   = sequence_ . genericReplicate n $ modify' breakLine
+renderBlock (NewlSep xs) = intersperse' (modify' breakLine) renderBlock xs
+renderBlock (Line x)     = renderLine x
+
+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 }
+renderLine (JuxtaPos xs) = mapM_ renderLine xs
+renderLine 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'
diff --git a/server/thermoprint-server.cabal b/server/thermoprint-server.cabal
index 5e9c61f..1ad4d4d 100644
--- a/server/thermoprint-server.cabal
+++ b/server/thermoprint-server.cabal
@@ -53,6 +53,7 @@ library
                      , filelock >=0.1.0 && <1
                      , bytestring >=0.10.6 && <1
                      , encoding >=0.8 && <1
+                     , binary >=0.7.5 && <1
   hs-source-dirs:      src
   default-language:    Haskell2010
 
diff --git a/server/thermoprint-server.nix b/server/thermoprint-server.nix
index d4ebb60..77911a8 100644
--- a/server/thermoprint-server.nix
+++ b/server/thermoprint-server.nix
@@ -1,4 +1,4 @@
-{ mkDerivation, base, bytestring, conduit, containers
+{ mkDerivation, base, binary, bytestring, conduit, containers
 , data-default-class, deepseq, dyre, either, encoding, exceptions
 , extended-reals, filelock, hspec, mmorph, monad-control
 , monad-logger, mtl, persistent, persistent-sqlite
@@ -13,11 +13,11 @@ mkDerivation {
   isLibrary = true;
   isExecutable = true;
   libraryHaskellDepends = [
-    base bytestring conduit containers data-default-class deepseq dyre
-    either encoding exceptions extended-reals filelock mmorph
-    monad-control monad-logger mtl persistent persistent-template
-    resourcet servant-server stm text thermoprint-spec time
-    transformers wai warp
+    base binary bytestring conduit containers data-default-class
+    deepseq dyre either encoding exceptions extended-reals filelock
+    mmorph monad-control monad-logger mtl persistent
+    persistent-template resourcet servant-server stm text
+    thermoprint-spec time transformers wai warp
   ];
   executableHaskellDepends = [
     base monad-logger mtl persistent-sqlite resourcet