aboutsummaryrefslogtreecommitdiff
path: root/server/src/Thermoprint/Server
diff options
context:
space:
mode:
authorGregor Kleen <gkleen@yggdrasil.li>2016-01-24 07:04:53 +0000
committerGregor Kleen <gkleen@yggdrasil.li>2016-01-24 07:04:53 +0000
commit7d3df6adce65e8840ef651a8a02a34a1a02083aa (patch)
treea5f82445047b6a4eefb803c0f3ee7dec5d1247f7 /server/src/Thermoprint/Server
parent6434397a3d103547b563ada27fd64c38cb05e1f0 (diff)
downloadthermoprint-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.hs39
-rw-r--r--server/src/Thermoprint/Server/Printer/Debug.hs32
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
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
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
5module Thermoprint.Server.Printer.Debug
6 ( Debug
7 ) where
8
9import Control.Monad.IO.Class
10import Control.Monad.Trans.Resource
11
12import Data.Text.Lazy (Text)
13import qualified Data.Text.Lazy as TL
14import qualified Data.Text.Lazy.IO as TL
15
16import Thermoprint.Printout
17import Thermoprint.Server.Printer
18
19import Data.List (intersperse)
20import Data.Foldable (toList)
21import Data.Monoid
22
23data 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]"