relational-query-HDBC: update LogChan interface. lift-out putVerbose logic.

relational-query-HDBC/src/Database/HDBC/Schema/Driver.hs

@@ -12,17 +12,20 @@
 module Database.HDBC.Schema.Driver (
   TypeMap,
 
-  Log, runLog,
+  Log, foldLog,
-  LogChan, newLogChan, takeLogs, putWarning, putError, putVerbose,
+  LogChan, emptyLogChan, takeLogs, putWarning, putError, putVerbose,
   failWith, hoistMaybe, maybeIO,
 
   Driver(Driver, typeMap, driverConfig, getFieldsWithMap, getPrimaryKey),
   emptyDriver,
-  getFields
+  getFields,
+
+  -- * Deprecated
+  runLog, newLogChan,
   ) where
 
 import Language.Haskell.TH (TypeQ)
-import Control.Applicative ((<$>), pure, (<*>))
+import Control.Applicative ((<$>), pure)
 import Control.Monad (MonadPlus, mzero)
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Maybe (MaybeT (..))
@@ -40,26 +43,33 @@ type TypeMap = [(String, TypeQ)]
 
 -- | Log string type for compile time.
 data Log
-  = Warning String
+  = Verbose String
+  | Warning String
   | Error String
 
 -- | Folding operation of 'Log' type.
-runLog :: (String -> t) -> (String -> t) -> Log -> t
+foldLog :: (String -> t) -> (String -> t) -> (String -> t) -> Log -> t
-runLog wf ef = d  where
+foldLog vf wf ef = d  where
+  d (Verbose m) = vf m
   d (Warning m) = wf m
   d (Error m)   = ef m
 
+{-# DEPRECATED runLog "use foldLog instead of this." #-}
+-- | Deprecated.
+runLog :: (String -> t) -> (String -> t) -> Log -> t
+runLog wf = foldLog wf wf
+
 -- | Channel to store compile-time warning messages.
-data LogChan =
+newtype LogChan = LogChan { chan :: IORef (DList Log) }
-  LogChan
-  { chan :: IORef (DList Log)
-  , verboseAsWarning :: Bool
-  }
 
 -- | Build and return a new instance of 'LogChan'.
+emptyLogChan :: IO LogChan
+emptyLogChan = LogChan <$> newIORef mempty
+
+{-# DEPRECATED newLogChan "use emptyLogChan instead of this." #-}
+-- | Deprecated.
 newLogChan :: Bool -> IO LogChan
-newLogChan v =
+newLogChan _ = emptyLogChan
-  LogChan <$> newIORef mempty <*> pure v
 
 -- | Take all logs list from channel.
 takeLogs :: LogChan -> IO [Log]
@@ -81,9 +91,7 @@ putError lchan = putLog lchan . Error
 
 -- | Put verbose compile-time message as warning when 'verboseAsWarning'.
 putVerbose :: LogChan -> String -> IO ()
-putVerbose lchan
+putVerbose lchan = putLog lchan . Verbose
-  | verboseAsWarning lchan  =  putWarning lchan . ("info: " ++)
-  | otherwise               =  const $ pure ()
 
 -- | Push an error string into 'LogChan' and return failed context.
 failWith :: LogChan -> String -> MaybeT IO a