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
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
|
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Thermoprint.Server.Printer.Generic
( genericPrint
) where
import Thermoprint.Printout
import Thermoprint.API (PrintingError(..))
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 (genericReplicate, intercalate)
import Data.Int (Int64)
import Prelude hiding (mapM_, sequence_)
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
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
, 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 ()
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]
newl :: Lazy.ByteString
newl = "\r\n"
newls :: Integer -> Lazy.ByteString
newls i = mconcat $ genericReplicate i newl
newls' :: Integer -> Render
newls' = mapM_ pushWord8 . LBS.unpack . newls
finalize :: Render -- TODO: adjust this to produce proper padding
finalize = newls' 2
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
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
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) = newls' n
renderBlock (NewlSep xs) = intersperse' (newls' 1) renderBlock xs
renderBlock (Line x) = undefined
|
