replace printparam' with a polymorphic construct

diff --git a/Network/AMQP/Utils/Connection.hs b/Network/AMQP/Utils/Connection.hs
index 62cba8f46456c11c1a77ae30b1dce66f551c8523..24a25e2a7136cf869cef9e6d5dab713063d4dbe4 100644 (file)
--- a/Network/AMQP/Utils/Connection.hs
+++ b/Network/AMQP/Utils/Connection.hs
@@ -17,11 +17,11 @@ import System.X509
 -- | opens a connection and a channel
 connect :: Args -> IO (Connection, Channel)
 connect args = do
-  printparam' "server" $ server args
-  printparam' "port" $ show $ port args
-  printparam' "vhost" $ vHost args
+  printparam "server" $ server args
+  printparam "port" $ show $ port args
+  printparam "vhost" $ vHost args
   printparam "connection_name" $ connectionName args
-  printparam' "connect timeout" $ (show (connect_timeout args)) ++ "s"
+  printparam "connect timeout" $ (show (connect_timeout args)) ++ "s"
   globalCertificateStore <- getSystemCertificateStore
   let myTLS =
         N.TLSSettings
@@ -59,7 +59,7 @@ connect args = do
 
 --  addChannelExceptionHandler chan
 --                             (\exception -> closeConnection conn >>
---                                  printparam' "exiting" (show exception) >>
+--                                  printparam "exiting" (show exception) >>
 --                                  killThread tid)
 --
 -- -- noop sharedValidationCache, handy when debugging
@@ -74,6 +74,6 @@ myCert :: Maybe FilePath -> Maybe FilePath -> t -> IO (Maybe Credential)
 myCert (Just cert') (Just key') _ = do
   result <- credentialLoadX509 cert' key'
   case result of
-    Left x -> printparam' "ERROR" x >> return Nothing
+    Left x -> printparam "ERROR" x >> return Nothing
     Right x -> return $ Just x
 myCert _ _ _ = return Nothing

diff --git a/Network/AMQP/Utils/Helpers.hs b/Network/AMQP/Utils/Helpers.hs
index 19c9b06bfa29b5902786bba8348eeda3b452be29..a6db9ea269515da98ae355107e2c848f2192fcc6 100644 (file)
--- a/Network/AMQP/Utils/Helpers.hs
+++ b/Network/AMQP/Utils/Helpers.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleInstances #-}
 module Network.AMQP.Utils.Helpers where
 
 import Control.Concurrent
@@ -29,13 +30,18 @@ printwithlabel labl (Just i) = do
   i
   hFlush stderr
 
--- | optional parameters
-printparam :: String -> Maybe String -> IO ()
-printparam labl ms = printwithlabel labl $ fmap (hPutStrLn stderr) ms
+class Flexprint a where
+  flexprint :: a -> Maybe (IO ())
 
--- | required parameters
-printparam' :: String -> String -> IO ()
-printparam' d s = printparam d (Just s)
+instance Flexprint (Maybe String) where
+  flexprint = fmap (hPutStrLn stderr)
+
+instance Flexprint String where
+  flexprint x = flexprint (Just x)
+
+-- | optional or required parameters
+printparam :: Flexprint a => String -> a -> IO ()
+printparam labl x = printwithlabel labl $ flexprint x
 
 -- | head chars of body
 printbody :: String -> Maybe BL.ByteString -> IO ()
@@ -253,7 +259,7 @@ doProc a numstring envi (exe:args) action = do
     createProcess (proc exe args) {std_out = out, std_err = Inherit}
   sout <- mapM BL.hGetContents h
   exitcode <- maybe 0 id (fmap BL.length sout) `seq` waitForProcess processhandle
-  printparam' (numstring ++ " call returned") $ show exitcode
+  printparam (numstring ++ " call returned") $ show exitcode
   if isJust action && isJust sout
     then ((fromJust action $ exitcode) (fromJust sout)) >> acke envi a
     else case exitcode of

diff --git a/agitprop.hs b/agitprop.hs
index 233e881d278fa82b3490add63cb3fee7e6713370..a34aec09caa2dd068775d5bb51b695146433e0ef 100644 (file)
--- a/agitprop.hs
+++ b/agitprop.hs
@@ -31,23 +31,23 @@ main = do
   hr "starting"
   tid <- myThreadId
   args <- getArgs >>= parseargs 'a'
-  printparam' "client version" $ "amqp-utils " ++ (showVersion version)
-  printparam' "routing key" $ rKey args
-  printparam' "exchange" $ currentExchange args
+  printparam "client version" $ "amqp-utils " ++ (showVersion version)
+  printparam "routing key" $ rKey args
+  printparam "exchange" $ currentExchange args
   isDir <-
     if inputFile args == "-"
       then return False
       else F.getFileStatus (inputFile args) >>= return . F.isDirectory
   if isDir
-    then printparam' "hotfolder" $ inputFile args
-    else printparam' "input file" $
+    then printparam "hotfolder" $ inputFile args
+    else printparam "input file" $
          (inputFile args) ++
          if (lineMode args)
            then " (line-by-line)"
            else ""
   (conn, chan) <- connect args
   addChannelExceptionHandler chan (X.throwTo tid)
-  printparam' "confirm mode" $ show $ confirm args
+  printparam "confirm mode" $ show $ confirm args
   if (confirm args)
     then do
       confirmSelect chan False
@@ -85,20 +85,20 @@ main = do
     exceptionHandler
   -- all done. wait and close.
   if (confirm args)
-    then waitForConfirms chan >>= (printparam' "confirmed") . show
+    then waitForConfirms chan >>= (printparam "confirmed") . show
     else return ()
   X.catch (closeConnection conn) exceptionHandler
 
 -- | A handler for clean exit
 exceptionHandler :: AMQPException -> IO ()
-exceptionHandler (ChannelClosedException Normal txt) = printparam' "exit" txt >> exitWith ExitSuccess
-exceptionHandler (ConnectionClosedException Normal txt) = printparam' "exit" txt >> exitWith ExitSuccess
-exceptionHandler x = printparam' "exception" (show x) >> exitWith (ExitFailure 1)
+exceptionHandler (ChannelClosedException Normal txt) = printparam "exit" txt >> exitWith ExitSuccess
+exceptionHandler (ConnectionClosedException Normal txt) = printparam "exit" txt >> exitWith ExitSuccess
+exceptionHandler x = printparam "exception" (show x) >> exitWith (ExitFailure 1)
 
 -- | The handler for publisher confirms
 confirmCallback :: (Word64, Bool, AckType) -> IO ()
 confirmCallback (deliveryTag, isAll, ackType) =
-  printparam'
+  printparam
     "confirmed"
     ((show deliveryTag) ++
      (if isAll
@@ -135,7 +135,7 @@ handleFile f [] x =
   X.catch
     (BL.readFile x >>= f (Just x))
     (\exception ->
-       printparam' "exception in handleFile" $
+       printparam "exception in handleFile" $
        show (exception :: X.SomeException))
 
 -- | Publish one message with our settings

diff --git a/arbeite.hs b/arbeite.hs
index 1969006d432ef01daf8af6948a7d372dd0ab4fed..d542efc468998d2bb14aba295d6b476ddc02b38a 100644 (file)
--- a/arbeite.hs
+++ b/arbeite.hs
@@ -22,10 +22,10 @@ main = do
   tid <- myThreadId
   args <- getArgs >>= parseargs 'r'
   X.onException
-    (printparam' "worker" $ fromJust $ fileProcess args)
+    (printparam "worker" $ fromJust $ fileProcess args)
     (error "-X option required")
   let addiArgs = reverse $ additionalArgs args
-  printparam' "client version" $ "amqp-utils " ++ (showVersion version)
+  printparam "client version" $ "amqp-utils " ++ (showVersion version)
   (conn, chan) <- connect args
   addChannelExceptionHandler chan (X.throwTo tid)
   queue <-
@@ -36,10 +36,10 @@ main = do
        (\(x, _, _) -> return x))
       (return)
       (fmap T.pack (qName args))
-  printparam' "queue name" $ T.unpack queue
+  printparam "queue name" $ T.unpack queue
   if (currentExchange args /= "")
     then do
-      printparam' "exchange" $ currentExchange args
+      printparam "exchange" $ currentExchange args
       bindQueue chan queue (T.pack $ currentExchange args) queue
     else return ()
   ctag <-
@@ -50,8 +50,8 @@ main = do
          then Ack
          else NoAck)
       (rpcServerCallback tid args addiArgs chan)
-  printparam' "consumer tag" $ T.unpack ctag
-  printparam' "send acks" $ show (ack args)
+  printparam "consumer tag" $ T.unpack ctag
+  printparam "send acks" $ show (ack args)
   printparam "requeue if rejected" $
     if (ack args)
       then Just (show (requeuenack args))
@@ -59,7 +59,7 @@ main = do
   hr "entering main loop"
   X.catch
     (forever $ threadDelay 5000000)
-    (\exception -> printparam' "exception" $ show (exception :: X.SomeException))
+    (\exception -> printparam "exception" $ show (exception :: X.SomeException))
   closeConnection conn
   hr "connection closed"
 
@@ -73,7 +73,7 @@ rpcServerCallback tid a addi c m@(msg, env) = do
     X.catch
       (printmsg Nothing m (anRiss a) now)
       (\x -> X.throwTo tid (x :: X.SomeException) >> return [])
-  either (\e -> printparam' "ERROR" (show (e :: X.SomeException))) return =<<
+  either (\e -> printparam "ERROR" (show (e :: X.SomeException))) return =<<
     X.try
       (optionalFileStuff m callbackoptions addi numstring a tid (Just reply))
   hr $ "END " ++ numstring

diff --git a/konsum.hs b/konsum.hs
index 10b321eb9e6ff0c72da69b498af8f483ba7b107d..d00954f85a520cfd190e02f971f28cc9c09aa1f6 100644 (file)
--- a/konsum.hs
+++ b/konsum.hs
@@ -18,11 +18,11 @@ main = do
   tid <- myThreadId
   args <- getArgs >>= parseargs 'k'
   let addiArgs = reverse $ additionalArgs args
-  printparam' "client version" $ "amqp-utils " ++ (showVersion version)
+  printparam "client version" $ "amqp-utils " ++ (showVersion version)
   (conn, chan) <- connect args
   addChannelExceptionHandler chan (X.throwTo tid)
   -- set prefetch
-  printparam' "prefetch" $ show $ preFetch args
+  printparam "prefetch" $ show $ preFetch args
   qos chan 0 (fromIntegral $ preFetch args) False
   -- attach to given queue? or build exclusive queue and bind it?
   queue <-
@@ -30,7 +30,7 @@ main = do
       (tempQueue chan (tmpQName args) (bindings args) (currentExchange args))
       (return)
       (fmap T.pack (qName args))
-  printparam' "queue name" $ T.unpack queue
+  printparam "queue name" $ T.unpack queue
   printparam "shown body chars" $ fmap show $ anRiss args
   printparam "temp dir" $ tempDir args
   printparam "callback" $ fileProcess args
@@ -44,8 +44,8 @@ main = do
          then Ack
          else NoAck)
       (myCallback args addiArgs tid)
-  printparam' "consumer tag" $ T.unpack ctag
-  printparam' "send acks" $ show (ack args)
+  printparam "consumer tag" $ T.unpack ctag
+  printparam "send acks" $ show (ack args)
   printparam "requeue if rejected" $
     if (ack args)
       then Just (show (requeuenack args))
@@ -53,7 +53,7 @@ main = do
   hr "entering main loop"
   X.catch
     (forever $ threadDelay 5000000)
-    (\exception -> printparam' "exception" $ show (exception :: X.SomeException))
+    (\exception -> printparam "exception" $ show (exception :: X.SomeException))
   closeConnection conn
   hr "connection closed"
 
@@ -67,7 +67,7 @@ tempQueue chan tmpqname bindlist x = do
   mapM_
     (\(xchange, bkey) ->
        bindQueue chan q (T.pack xchange) (T.pack bkey) >>
-       printparam' "binding" (xchange ++ ":" ++ bkey))
+       printparam "binding" (xchange ++ ":" ++ bkey))
     (if null bindlist
        then [(x, "#")]
        else bindlist)
@@ -84,7 +84,7 @@ myCallback a addi tid m@(_, envi) = do
       (printmsg Nothing m (anRiss a) now)
       (\x -> X.throwTo tid (x :: X.SomeException) >> return [])
   either
-    (\e -> printparam' "ERROR" (show (e :: X.SomeException)) >> reje envi a)
+    (\e -> printparam "ERROR" (show (e :: X.SomeException)) >> reje envi a)
     return =<<
     X.try (optionalFileStuff m callbackoptions addi numstring a tid Nothing)
   hr $ "END " ++ numstring

diff --git a/plane.hs b/plane.hs
index edf50197f2a0e5ad7f35c062585f86a622165883..6013958a338aa9263b05b2858d122efb9ca434a5 100644 (file)
--- a/plane.hs
+++ b/plane.hs
@@ -24,27 +24,27 @@ main = do
   tid <- myThreadId
   args <- getArgs >>= parseargs 'p'
   X.onException
-    (printparam' "rpc_timeout" $ show (rpc_timeout args) ++ "s")
+    (printparam "rpc_timeout" $ show (rpc_timeout args) ++ "s")
     (error $ "invalid rpc_timeout")
-  printparam' "client version" $ "amqp-utils " ++ (showVersion version)
-  printparam' "destination queue" $ tmpQName args
+  printparam "client version" $ "amqp-utils " ++ (showVersion version)
+  printparam "destination queue" $ tmpQName args
   (conn, chan) <- connect args
   addChannelExceptionHandler chan (X.throwTo tid)
   (q, _, _) <- declareQueue chan newQueue {queueExclusive = True}
   if (currentExchange args /= "")
     then do
-      printparam' "exchange" $ currentExchange args
+      printparam "exchange" $ currentExchange args
       bindQueue chan q (T.pack $ currentExchange args) q
     else return ()
-  printparam' "input file" $ inputFile args
+  printparam "input file" $ inputFile args
   message <-
     if inputFile args == "-"
       then BL.getContents
       else BL.readFile (inputFile args)
-  printparam' "output file" $ outputFile args
+  printparam "output file" $ outputFile args
   h <- if outputFile args == "-" then return stdout else openBinaryFile (outputFile args) WriteMode
   ctag <- consumeMsgs chan q NoAck (rpcClientCallback h tid args)
-  printparam' "consumer tag" $ T.unpack ctag
+  printparam "consumer tag" $ T.unpack ctag
   now <- getCurrentTime >>= return . floor . utcTimeToPOSIXSeconds
   hr "publishing request"
   _ <- publishMsg
@@ -69,7 +69,7 @@ main = do
        ec <- exceptionHandler x
        hr "closing connection"
        closeConnection conn
-       printparam' "exiting" $ show ec
+       printparam "exiting" $ show ec
        exitWith ec)
 
 exceptionHandler :: RpcException -> IO (ExitCode)