diff options
author | Gregor Kleen <gkleen@yggdrasil.li> | 2016-01-24 07:04:53 +0000 |
---|---|---|
committer | Gregor Kleen <gkleen@yggdrasil.li> | 2016-01-24 07:04:53 +0000 |
commit | 7d3df6adce65e8840ef651a8a02a34a1a02083aa (patch) | |
tree | a5f82445047b6a4eefb803c0f3ee7dec5d1247f7 /server/src/Thermoprint/Server | |
parent | 6434397a3d103547b563ada27fd64c38cb05e1f0 (diff) | |
download | thermoprint-7d3df6adce65e8840ef651a8a02a34a1a02083aa.tar thermoprint-7d3df6adce65e8840ef651a8a02a34a1a02083aa.tar.gz thermoprint-7d3df6adce65e8840ef651a8a02a34a1a02083aa.tar.bz2 thermoprint-7d3df6adce65e8840ef651a8a02a34a1a02083aa.tar.xz thermoprint-7d3df6adce65e8840ef651a8a02a34a1a02083aa.zip |
Revert "Broken existentially quantified printer config"
This reverts commit 6434397a3d103547b563ada27fd64c38cb05e1f0.
Diffstat (limited to 'server/src/Thermoprint/Server')
-rw-r--r-- | server/src/Thermoprint/Server/Printer.hs | 39 | ||||
-rw-r--r-- | server/src/Thermoprint/Server/Printer/Debug.hs | 32 |
2 files changed, 6 insertions, 65 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 | ||
13 | module Thermoprint.Server.Printer | 10 | module 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 | ||
46 | import Control.Concurrent.STM | 42 | import Control.Concurrent.STM |
47 | 43 | ||
48 | import Data.Default.Class | 44 | data Printer = Printer |
49 | 45 | { print :: forall m. (MonadIO m) => Printout -> m (Maybe PrintingError) | |
50 | import Prelude hiding (print) | ||
51 | |||
52 | class IsPrinter a where | ||
53 | toMethod :: forall m. (MonadResource m) => a -> (forall m1. (MonadResource m1) => m (Printout -> m1 (Maybe PrintingError))) | ||
54 | |||
55 | instance (MonadResource m) => IsPrinter (Printer m) where | ||
56 | toMethod Printer{..} = return print | ||
57 | |||
58 | instance (MonadResource m) => IsPrinter (PrinterSpec m) where | ||
59 | toMethod (PS p) = toMethod p | ||
60 | |||
61 | data PrinterSpec m = forall p. IsPrinter p => PS p | ||
62 | |||
63 | data 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 | ||
76 | instance Default Queue where | 57 | printer :: (MonadIO m) => (forall m. (MonadIO m) => Printout -> m (Maybe PrintingError)) -> m Printer |
77 | def = Queue | 58 | printer f = Printer f <$> liftIO (newTVarIO $ Queue Seq.empty Nothing Seq.empty) |
78 | { pending = Seq.empty | ||
79 | , current = Nothing | ||
80 | , history = Seq.empty | ||
81 | } | ||
82 | |||
83 | printer :: (MonadResource m, MonadResource m1, IsPrinter p) => p -> m (Printer m1) | ||
84 | -- ^ Version of 'Printer' handling the initialisation of the 'TVar' | ||
85 | printer p = Printer <$> toMethod p <*> liftIO (newTVarIO def) | ||
86 | 59 | ||
87 | atomically' :: MonadIO m => STM a -> m a | 60 | atomically' :: MonadIO m => STM a -> m a |
88 | atomically' = liftIO . atomically | 61 | atomically' = liftIO . atomically |
89 | 62 | ||
90 | runPrinter :: ( MonadReader ConnectionPool m | 63 | runPrinter :: ( 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 |
96 | runPrinter Printer{..} = forever $ do | 69 | runPrinter Printer{..} = forever $ do |
97 | jobId <- atomically' $ do | 70 | jobId <- atomically' $ do |
diff --git a/server/src/Thermoprint/Server/Printer/Debug.hs b/server/src/Thermoprint/Server/Printer/Debug.hs deleted file mode 100644 index 81e43a3..0000000 --- a/server/src/Thermoprint/Server/Printer/Debug.hs +++ /dev/null | |||
@@ -1,32 +0,0 @@ | |||
1 | {-# LANGUAGE EmptyDataDecls #-} | ||
2 | {-# LANGUAGE OverloadedStrings #-} | ||
3 | {-# LANGUAGE RankNTypes #-} | ||
4 | |||
5 | module Thermoprint.Server.Printer.Debug | ||
6 | ( Debug | ||
7 | ) where | ||
8 | |||
9 | import Control.Monad.IO.Class | ||
10 | import Control.Monad.Trans.Resource | ||
11 | |||
12 | import Data.Text.Lazy (Text) | ||
13 | import qualified Data.Text.Lazy as TL | ||
14 | import qualified Data.Text.Lazy.IO as TL | ||
15 | |||
16 | import Thermoprint.Printout | ||
17 | import Thermoprint.Server.Printer | ||
18 | |||
19 | import Data.List (intersperse) | ||
20 | import Data.Foldable (toList) | ||
21 | import Data.Monoid | ||
22 | |||
23 | data Debug | ||
24 | |||
25 | -- instance IsPrinter Debug where | ||
26 | -- toMethod _ = (>> return Nothing) . liftIO . TL.putStrLn . cotext' | ||
27 | |||
28 | -- cotext' :: Printout -> Text | ||
29 | -- cotext' = mconcat . intersperse "\n\n" . map (mconcat . map cotext'' . toList) . toList | ||
30 | -- where | ||
31 | -- cotext'' (Cooked b) = cotext b | ||
32 | -- cotext'' (Raw _) = "[Raw]" | ||