From 8e8394452565dbd338427c6304c324d5fb51b908 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 15 Feb 2016 19:37:25 +0000 Subject: Working prototype of Generic --- server/src/Thermoprint/Server/Printer/Generic.hs | 106 ++++++++++++++++------- 1 file changed, 76 insertions(+), 30 deletions(-) (limited to 'server/src') 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' -- cgit v1.2.3