1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
|
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Thermoprint.Server.Printer.Generic
( genericPrint
) where
import Thermoprint.Printout
import Thermoprint.API (PrintingError(IOError))
import Thermoprint.Server.Printer
import System.FileLock
import System.IO
import Data.Sequence (Seq, (|>), (<|), ViewL(..), viewl)
import qualified Data.Sequence as Seq
import qualified Data.ByteString.Lazy as Lazy (ByteString)
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Char8 as CLBS
import qualified Data.Text.Lazy as Lazy (Text)
import qualified Data.Text.Lazy as TL
import Data.Encoding
import Data.Encoding.CP437
import Data.Word
import Control.Monad
import Control.Monad.Reader
import Control.Monad.Trans.State
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import Data.Acquire
import Control.Exception.Base (IOException)
import Control.Monad.Catch
import Data.Foldable
import Data.List (intersperse, genericReplicate, intercalate)
import Data.Int (Int64)
import Prelude hiding (mapM_, sequence_)
lockedFile :: FilePath -> Acquire (FileLock, Handle)
lockedFile f = mkAcquire ((,) <$> lockFile f Exclusive <*> openFile f AppendMode) (\(lock, h) -> () <$ hClose h <* unlockFile lock)
withLockedFile :: (MonadIO m, MonadMask m) => FilePath -> (Handle -> m a) -> m a
withLockedFile path f = withEx (lockedFile path) (f . snd)
genericPrint :: FilePath -> PrinterMethod
genericPrint path = PM $ flip catches handlers . withLockedFile path . print
where
print printout handle = liftIO $ runReaderT (bracket_ initialize (render printout) finalize) handle >> return Nothing
handlers = [ Handler $ return . Just . IOError . (show :: IOException -> String)
, Handler $ return . Just . EncError
]
type Render = ReaderT Handle IO ()
encode' :: ByteSink m => String -> m ()
encode' = encode CP437
width :: Int64
width = 32
esc :: Word8
esc = 27
escSequence :: [Word8] -> Render
escSequence = mapM_ pushWord8 . (esc:)
initialize :: Render
initialize = replicateM_ 2 $ escSequence [64]
finalize :: Render -- TODO: adjust this to produce proper padding
finalize = encode' "\n\n\n"
intersperse' :: b -> (a -> b) -> Seq a -> Seq b
intersperse' _ _ (viewl -> EmptyL) = Seq.empty
intersperse' _ f (viewl -> x :< (viewl -> EmptyL)) = Seq.singleton $ f x
intersperse' b f (viewl -> x :< xs) = f x <| b <| intersperse' b f xs
render :: Printout -> Render
render = sequence_ . intersperse' (encode' "\n\n") renderPar
renderPar :: Paragraph -> Render
renderPar = mapM_ renderChunk
where
renderChunk (Raw bs) = mapM_ pushWord8 $ LBS.unpack bs
renderChunk (Cooked block) = renderBlock block
renderBlock :: Block -> Render
renderBlock (VSpace n) = encode' $ genericReplicate n '\n'
renderBlock (NewlSep xs) = sequence_ intercalate (encode' "\n") . map renderBlock . toList $ xs
renderBlock (Line x) = undefined
|