aboutsummaryrefslogtreecommitdiff
path: root/server/src/Thermoprint/Server/Printer.hs
diff options
context:
space:
mode:
Diffstat (limited to 'server/src/Thermoprint/Server/Printer.hs')
-rw-r--r--server/src/Thermoprint/Server/Printer.hs39
1 files changed, 6 insertions, 33 deletions
diff --git a/server/src/Thermoprint/Server/Printer.hs b/server/src/Thermoprint/Server/Printer.hs
index cd12297..f34b2fa 100644
--- a/server/src/Thermoprint/Server/Printer.hs
+++ b/server/src/Thermoprint/Server/Printer.hs
@@ -1,18 +1,14 @@
1{-# LANGUAGE RankNTypes #-} 1{-# LANGUAGE RankNTypes #-}
2{-# LANGUAGE ImpredicativeTypes #-}
3{-# LANGUAGE MultiParamTypeClasses #-} 2{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE FlexibleContexts #-} 3{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE RecordWildCards #-} 4{-# LANGUAGE RecordWildCards #-}
6{-# LANGUAGE OverloadedStrings #-} 5{-# LANGUAGE OverloadedStrings #-}
7{-# LANGUAGE TemplateHaskell #-} 6{-# LANGUAGE TemplateHaskell #-}
8{-# LANGUAGE StandaloneDeriving #-} 7{-# LANGUAGE StandaloneDeriving #-}
9{-# LANGUAGE ExistentialQuantification #-}
10{-# LANGUAGE RecordWildCards #-}
11{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} 8{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
12 9
13module Thermoprint.Server.Printer 10module Thermoprint.Server.Printer
14 ( Printer(..), printer 11 ( Printer(..), printer
15 , IsPrinter(..), PrinterSpec(..)
16 , Queue(..) 12 , Queue(..)
17 , runPrinter 13 , runPrinter
18 ) where 14 ) where
@@ -45,23 +41,8 @@ import Control.Monad (forever)
45 41
46import Control.Concurrent.STM 42import Control.Concurrent.STM
47 43
48import Data.Default.Class 44data Printer = Printer
49 45 { print :: forall m. (MonadIO m) => Printout -> m (Maybe PrintingError)
50import Prelude hiding (print)
51
52class IsPrinter a where
53 toMethod :: forall m. (MonadResource m) => a -> (forall m1. (MonadResource m1) => m (Printout -> m1 (Maybe PrintingError)))
54
55instance (MonadResource m) => IsPrinter (Printer m) where
56 toMethod Printer{..} = return print
57
58instance (MonadResource m) => IsPrinter (PrinterSpec m) where
59 toMethod (PS p) = toMethod p
60
61data PrinterSpec m = forall p. IsPrinter p => PS p
62
63data Printer m = Printer
64 { print :: Printout -> m (Maybe PrintingError)
65 , queue :: TVar Queue 46 , queue :: TVar Queue
66 } 47 }
67 48
@@ -73,25 +54,17 @@ data Queue = Queue
73 } 54 }
74 deriving (Typeable, Generic, NFData) 55 deriving (Typeable, Generic, NFData)
75 56
76instance Default Queue where 57printer :: (MonadIO m) => (forall m. (MonadIO m) => Printout -> m (Maybe PrintingError)) -> m Printer
77 def = Queue 58printer f = Printer f <$> liftIO (newTVarIO $ Queue Seq.empty Nothing Seq.empty)
78 { pending = Seq.empty
79 , current = Nothing
80 , history = Seq.empty
81 }
82
83printer :: (MonadResource m, MonadResource m1, IsPrinter p) => p -> m (Printer m1)
84-- ^ Version of 'Printer' handling the initialisation of the 'TVar'
85printer p = Printer <$> toMethod p <*> liftIO (newTVarIO def)
86 59
87atomically' :: MonadIO m => STM a -> m a 60atomically' :: MonadIO m => STM a -> m a
88atomically' = liftIO . atomically 61atomically' = liftIO . atomically
89 62
90runPrinter :: ( MonadReader ConnectionPool m 63runPrinter :: ( MonadReader ConnectionPool m
64 , MonadIO m
91 , MonadLogger m 65 , MonadLogger m
92 , MonadResource m
93 , MonadBaseControl IO m 66 , MonadBaseControl IO m
94 ) => Printer m -> m () 67 ) => Printer -> m ()
95-- ^ Loop 'forever' pushing entries from the 'Queue' associated to a 'Printer' into its 'print'-method 68-- ^ Loop 'forever' pushing entries from the 'Queue' associated to a 'Printer' into its 'print'-method
96runPrinter Printer{..} = forever $ do 69runPrinter Printer{..} = forever $ do
97 jobId <- atomically' $ do 70 jobId <- atomically' $ do