From 7d3df6adce65e8840ef651a8a02a34a1a02083aa Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 24 Jan 2016 07:04:53 +0000 Subject: Revert "Broken existentially quantified printer config" This reverts commit 6434397a3d103547b563ada27fd64c38cb05e1f0. --- server/src/Thermoprint/Server.hs | 21 +++----------- server/src/Thermoprint/Server/Printer.hs | 39 ++++---------------------- server/src/Thermoprint/Server/Printer/Debug.hs | 32 --------------------- server/thermoprint-server.cabal | 1 - 4 files changed, 10 insertions(+), 83 deletions(-) delete mode 100644 server/src/Thermoprint/Server/Printer/Debug.hs (limited to 'server') diff --git a/server/src/Thermoprint/Server.hs b/server/src/Thermoprint/Server.hs index 4e8d962..39bf0a1 100644 --- a/server/src/Thermoprint/Server.hs +++ b/server/src/Thermoprint/Server.hs @@ -3,11 +3,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ViewPatterns #-} module Thermoprint.Server ( thermoprintServer - , Config(..), withPrinters + , Config(..) , module Data.Default.Class , module Servant.Server.Internal.Enter , module Thermoprint.Server.Printer @@ -20,8 +19,7 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (maybe) -import Data.Foldable (mapM_, forM_, foldlM) -import Data.Monoid +import Data.Foldable (mapM_, forM_) import Control.Monad.Trans.Resource import Control.Monad.Trans.Control @@ -29,8 +27,6 @@ import Control.Monad.Logger import Control.Monad.Reader import Control.Monad.IO.Class -import Control.Monad.Writer - import Control.Concurrent import Data.Text (Text) @@ -66,9 +62,9 @@ instance Default Config where thermoprintServer :: ( MonadLoggerIO m - , MonadReader ConnectionPool m - , MonadResource m + , MonadIO m , MonadBaseControl IO m + , MonadReader ConnectionPool m ) => (m :~> IO) -- ^ 'dyre' controls the base of the monad-transformer-stack ('IO') but we let the user specify the rest of it. Therefore we require a specification of how to enter the stack. -> Config -> IO () -- ^ Run the server @@ -83,12 +79,3 @@ thermoprintServer io = Dyre.wrapMain $ Dyre.defaultParams mapM_ ($(logWarnS) "DB") =<< runSqlPool (runMigrationSilent migrateAll) =<< ask forM_ printers $ liftBaseDiscard forkIO . runPrinter liftIO . Warp.runSettings warpSettings . serve thermoprintAPI . flip enter API.thermoprintServer =<< handlerNat printers - -withPrinters :: MonadResource m => Config -> [PrinterSpec] -> m Config --- ^ Helper for comfortably specifying a set of 'Printer's -withPrinters cfg = fmap (\ps -> cfg { printers = printers cfg <> ps }) . foldlM (\ps p -> Map.insert (nextKey ps) <$> printer p <*> pure ps) Map.empty - where - nextKey :: Map PrinterId a -> PrinterId - nextKey (Map.keys -> keys) - | null keys = 0 - | otherwise = succ $ maximum keys 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 @@ {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Thermoprint.Server.Printer ( Printer(..), printer - , IsPrinter(..), PrinterSpec(..) , Queue(..) , runPrinter ) where @@ -45,23 +41,8 @@ import Control.Monad (forever) import Control.Concurrent.STM -import Data.Default.Class - -import Prelude hiding (print) - -class IsPrinter a where - toMethod :: forall m. (MonadResource m) => a -> (forall m1. (MonadResource m1) => m (Printout -> m1 (Maybe PrintingError))) - -instance (MonadResource m) => IsPrinter (Printer m) where - toMethod Printer{..} = return print - -instance (MonadResource m) => IsPrinter (PrinterSpec m) where - toMethod (PS p) = toMethod p - -data PrinterSpec m = forall p. IsPrinter p => PS p - -data Printer m = Printer - { print :: Printout -> m (Maybe PrintingError) +data Printer = Printer + { print :: forall m. (MonadIO m) => Printout -> m (Maybe PrintingError) , queue :: TVar Queue } @@ -73,25 +54,17 @@ data Queue = Queue } deriving (Typeable, Generic, NFData) -instance Default Queue where - def = Queue - { pending = Seq.empty - , current = Nothing - , history = Seq.empty - } - -printer :: (MonadResource m, MonadResource m1, IsPrinter p) => p -> m (Printer m1) --- ^ Version of 'Printer' handling the initialisation of the 'TVar' -printer p = Printer <$> toMethod p <*> liftIO (newTVarIO def) +printer :: (MonadIO m) => (forall m. (MonadIO m) => Printout -> m (Maybe PrintingError)) -> m Printer +printer f = Printer f <$> liftIO (newTVarIO $ Queue Seq.empty Nothing Seq.empty) atomically' :: MonadIO m => STM a -> m a atomically' = liftIO . atomically runPrinter :: ( MonadReader ConnectionPool m + , MonadIO m , MonadLogger m - , MonadResource m , MonadBaseControl IO m - ) => Printer m -> m () + ) => Printer -> m () -- ^ Loop 'forever' pushing entries from the 'Queue' associated to a 'Printer' into its 'print'-method runPrinter Printer{..} = forever $ do 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 @@ -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} - -module Thermoprint.Server.Printer.Debug - ( Debug - ) where - -import Control.Monad.IO.Class -import Control.Monad.Trans.Resource - -import Data.Text.Lazy (Text) -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.IO as TL - -import Thermoprint.Printout -import Thermoprint.Server.Printer - -import Data.List (intersperse) -import Data.Foldable (toList) -import Data.Monoid - -data Debug - --- instance IsPrinter Debug where --- toMethod _ = (>> return Nothing) . liftIO . TL.putStrLn . cotext' - --- cotext' :: Printout -> Text --- cotext' = mconcat . intersperse "\n\n" . map (mconcat . map cotext'' . toList) . toList --- where --- cotext'' (Cooked b) = cotext b --- cotext'' (Raw _) = "[Raw]" diff --git a/server/thermoprint-server.cabal b/server/thermoprint-server.cabal index dd495c0..185a0f3 100644 --- a/server/thermoprint-server.cabal +++ b/server/thermoprint-server.cabal @@ -21,7 +21,6 @@ library , Thermoprint.Server.Database , Thermoprint.Server.API , Thermoprint.Server.Printer - , Thermoprint.Server.Printer.Debug other-modules: Thermoprint.Server.Database.Instances -- other-extensions: build-depends: base >=4.8 && <5 -- cgit v1.2.3