From 6434397a3d103547b563ada27fd64c38cb05e1f0 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Sat, 23 Jan 2016 19:42:22 +0000
Subject: Broken existentially quantified printer config

---
 server/src/Thermoprint/Server/Printer.hs       | 39 ++++++++++++++++++++++----
 server/src/Thermoprint/Server/Printer/Debug.hs | 32 +++++++++++++++++++++
 2 files changed, 65 insertions(+), 6 deletions(-)
 create mode 100644 server/src/Thermoprint/Server/Printer/Debug.hs

(limited to 'server/src/Thermoprint/Server')

diff --git a/server/src/Thermoprint/Server/Printer.hs b/server/src/Thermoprint/Server/Printer.hs
index f34b2fa..cd12297 100644
--- a/server/src/Thermoprint/Server/Printer.hs
+++ b/server/src/Thermoprint/Server/Printer.hs
@@ -1,14 +1,18 @@
 {-# 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
@@ -41,8 +45,23 @@ import Control.Monad (forever)
 
 import Control.Concurrent.STM
 
-data Printer = Printer
-  { print :: forall m. (MonadIO m) => Printout -> m (Maybe PrintingError)
+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)
   , queue :: TVar Queue
   }
 
@@ -54,17 +73,25 @@ data Queue = Queue
   }
   deriving (Typeable, Generic, NFData)
 
-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)
+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)
 
 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 ()
+              ) => Printer m -> 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
new file mode 100644
index 0000000..81e43a3
--- /dev/null
+++ b/server/src/Thermoprint/Server/Printer/Debug.hs
@@ -0,0 +1,32 @@
+{-# 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]"
-- 
cgit v1.2.3