aboutsummaryrefslogtreecommitdiff
path: root/server/src
diff options
context:
space:
mode:
authorGregor Kleen <gkleen@yggdrasil.li>2016-01-25 13:25:18 +0000
committerGregor Kleen <gkleen@yggdrasil.li>2016-01-25 13:25:18 +0000
commit9d9bad89241bfa14255361dd8452ad40291a9684 (patch)
tree5e0f940724f060fb732c36e81217b10c5eb69229 /server/src
parent09f4d0431ef3015653b6b78f1d413454519380bd (diff)
downloadthermoprint-9d9bad89241bfa14255361dd8452ad40291a9684.tar
thermoprint-9d9bad89241bfa14255361dd8452ad40291a9684.tar.gz
thermoprint-9d9bad89241bfa14255361dd8452ad40291a9684.tar.bz2
thermoprint-9d9bad89241bfa14255361dd8452ad40291a9684.tar.xz
thermoprint-9d9bad89241bfa14255361dd8452ad40291a9684.zip
Cleaned up printer declaration
Diffstat (limited to 'server/src')
-rw-r--r--server/src/Thermoprint/Server.hs2
-rw-r--r--server/src/Thermoprint/Server/Printer.hs20
-rw-r--r--server/src/Thermoprint/Server/Printer/Debug.hs14
3 files changed, 8 insertions, 28 deletions
diff --git a/server/src/Thermoprint/Server.hs b/server/src/Thermoprint/Server.hs
index ed20983..3d0e97e 100644
--- a/server/src/Thermoprint/Server.hs
+++ b/server/src/Thermoprint/Server.hs
@@ -84,7 +84,7 @@ thermoprintServer io = Dyre.wrapMain $ Dyre.defaultParams
84 forM_ printers $ resourceForkIO . runPrinter 84 forM_ printers $ resourceForkIO . runPrinter
85 liftIO . Warp.runSettings warpSettings . serve thermoprintAPI . flip enter API.thermoprintServer =<< handlerNat printers 85 liftIO . Warp.runSettings warpSettings . serve thermoprintAPI . flip enter API.thermoprintServer =<< handlerNat printers
86 86
87withPrinters :: MonadResource m => Config -> [PrinterSpec m] -> m Config 87withPrinters :: MonadResource m => Config -> [m PrinterMethod] -> m Config
88withPrinters cfg pss = (\map -> cfg { printers = map }) <$> foldlM (\map spec -> Map.insert (nextKey map) <$> printer spec <*> pure map) Map.empty pss 88withPrinters cfg pss = (\map -> cfg { printers = map }) <$> foldlM (\map spec -> Map.insert (nextKey map) <$> printer spec <*> pure map) Map.empty pss
89 where 89 where
90 nextKey map 90 nextKey map
diff --git a/server/src/Thermoprint/Server/Printer.hs b/server/src/Thermoprint/Server/Printer.hs
index 46b8a53..5b1b7b0 100644
--- a/server/src/Thermoprint/Server/Printer.hs
+++ b/server/src/Thermoprint/Server/Printer.hs
@@ -1,7 +1,4 @@
1{-# LANGUAGE RankNTypes #-} 1{-# LANGUAGE RankNTypes #-}
2{-# LANGUAGE TypeSynonymInstances #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleContexts #-} 2{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE RecordWildCards #-} 3{-# LANGUAGE RecordWildCards #-}
7{-# LANGUAGE OverloadedStrings #-} 4{-# LANGUAGE OverloadedStrings #-}
@@ -12,7 +9,8 @@
12{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} 9{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
13 10
14module Thermoprint.Server.Printer 11module Thermoprint.Server.Printer
15 ( PrinterMethod(..), PrinterSpec(..), IsPrinter(..), Printer(..), printer 12 ( PrinterMethod(..), Printer(..)
13 , printer
16 , Queue(..) 14 , Queue(..)
17 , runPrinter 15 , runPrinter
18 , addToQueue 16 , addToQueue
@@ -48,16 +46,6 @@ import Control.Monad (forever)
48import Control.Concurrent.STM 46import Control.Concurrent.STM
49 47
50newtype PrinterMethod = PM { unPM :: forall m. (MonadResource m, MonadLogger m) => Printout -> m (Maybe PrintingError) } 48newtype PrinterMethod = PM { unPM :: forall m. (MonadResource m, MonadLogger m) => Printout -> m (Maybe PrintingError) }
51data PrinterSpec m = forall p. IsPrinter p m => PS p
52
53class IsPrinter p m where
54 printMethod :: p -> m PrinterMethod
55
56instance Applicative m => IsPrinter PrinterMethod m where
57 printMethod = pure
58
59instance IsPrinter (PrinterSpec m) m where
60 printMethod (PS p) = printMethod p
61 49
62data Printer = Printer 50data Printer = Printer
63 { print :: PrinterMethod 51 { print :: PrinterMethod
@@ -79,8 +67,8 @@ instance Default Queue where
79 , history = Seq.empty 67 , history = Seq.empty
80 } 68 }
81 69
82printer :: (MonadResource m, IsPrinter p m) => p -> m Printer 70printer :: MonadResource m => m PrinterMethod -> m Printer
83printer spec = Printer <$> printMethod spec <*> liftIO (newTVarIO def) 71printer p = Printer <$> p <*> liftIO (newTVarIO def)
84 72
85atomically' :: MonadIO m => STM a -> m a 73atomically' :: MonadIO m => STM a -> m a
86atomically' = liftIO . atomically 74atomically' = liftIO . atomically
diff --git a/server/src/Thermoprint/Server/Printer/Debug.hs b/server/src/Thermoprint/Server/Printer/Debug.hs
index b8c1430..721ec84 100644
--- a/server/src/Thermoprint/Server/Printer/Debug.hs
+++ b/server/src/Thermoprint/Server/Printer/Debug.hs
@@ -1,11 +1,8 @@
1{-# LANGUAGE OverloadedStrings #-} 1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE RankNTypes #-}
3{-# LANGUAGE TemplateHaskell #-} 2{-# LANGUAGE TemplateHaskell #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
5{-# LANGUAGE FlexibleInstances #-}
6 3
7module Thermoprint.Server.Printer.Debug 4module Thermoprint.Server.Printer.Debug
8 ( Debug(..) 5 ( debugPrint
9 ) where 6 ) where
10 7
11import Control.Monad.IO.Class 8import Control.Monad.IO.Class
@@ -24,13 +21,8 @@ import Data.List (intersperse)
24import Data.Foldable (toList) 21import Data.Foldable (toList)
25import Data.Monoid 22import Data.Monoid
26 23
27data Debug = Debug 24debugPrint :: PrinterMethod
28 25debugPrint = PM $ (>> return Nothing) . $(logDebugS) "Printer.Debug" . T.pack . show . cotext'
29instance Applicative m => IsPrinter Debug m where
30 printMethod _ = printMethod debugPrinter
31
32debugPrinter :: PrinterMethod
33debugPrinter = PM $ (>> return Nothing) . $(logDebugS) "Printer.Debug" . T.pack . show . cotext'
34 26
35cotext' :: Printout -> Text 27cotext' :: Printout -> Text
36cotext' = mconcat . intersperse "\n\n" . map (mconcat . map cotext'' . toList) . toList 28cotext' = mconcat . intersperse "\n\n" . map (mconcat . map cotext'' . toList) . toList