Apply failWith to SQLServer driver.

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

@@ -17,15 +17,18 @@ module Database.HDBC.Schema.SQLServer (
 import qualified Database.Relational.Schema.SQLServerSyscat.Columns as Columns
 import qualified Database.Relational.Schema.SQLServerSyscat.Types as Types
 
+import Control.Applicative ((<|>))
+import Control.Monad (guard)
 import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Maybe (MaybeT)
 import Data.Map (fromList)
 import Data.Maybe (catMaybes)
 import Database.HDBC (IConnection, SqlValue)
 import Database.HDBC.Record.Query (runQuery')
 import Database.HDBC.Record.Persistable ()
 import Database.HDBC.Schema.Driver
-  (TypeMap, LogChan, putVerbose, maybeIO,
-   Driver, getFieldsWithMap, getPrimaryKey, emptyDriver)
+  (TypeMap, LogChan, putVerbose, failWith, maybeIO,
+   Driver, hoistMaybe, getFieldsWithMap, getPrimaryKey, emptyDriver)
 import Database.Record.TH (makeRecordPersistableWithSqlTypeDefaultFromDefined)
 import Database.Relational.Schema.SQLServer (columnTypeQuerySQL, getType, normalizeColumn,
                                             notNull, primaryKeyQuerySQL)
@@ -46,8 +49,8 @@ logPrefix = ("SQLServer: " ++)
 putLog :: LogChan -> String -> IO ()
 putLog lchan = putVerbose lchan . logPrefix
 
-compileErrorIO :: String -> IO a
-compileErrorIO =  fail . logPrefix
+compileErrorIO :: LogChan -> String -> MaybeT IO a
+compileErrorIO lchan = failWith lchan . logPrefix
 
 getPrimaryKey' :: IConnection conn
                => conn
@@ -70,21 +73,20 @@ getFields' :: IConnection conn
            -> IO ([(String, TypeQ)], [Int])
 getFields' tmap conn lchan scm tbl = maybeIO ([], []) id $ do
     rows <- lift $ runQuery' conn columnTypeQuerySQL (scm, tbl)
-    case rows of
-      [] -> lift . compileErrorIO
-            $ "getFields: No columns found: schema = " ++ scm ++ ", table = " ++ tbl
-      _  -> return ()
+    guard (not $ null rows) <|>
+      compileErrorIO lchan
+      ("getFields: No columns found: schema = " ++ scm ++ ", table = " ++ tbl)
     let columnId ((cols,_),_) = Columns.columnId cols - 1
     let notNullIdxs = map (fromIntegral . columnId) . filter notNull $ rows
     lift . putLog lchan
         $ "getFields: num of columns = " ++ show (length rows)
         ++ ", not null columns = " ++ show notNullIdxs
-    let getType' rec@((_,typs),typScms) = case getType (fromList tmap) rec of
-          Nothing -> compileErrorIO
-                     $ "Type mapping is not defined against SQLServer type: "
-                     ++ typScms ++ "." ++ Types.name typs
-          Just p  -> return p
-    types <- lift $ mapM getType' rows
+    let getType' rec'@((_,typs),typScms) =
+          hoistMaybe (getType (fromList tmap) rec') <|>
+          compileErrorIO lchan
+          ("Type mapping is not defined against SQLServer type: "
+           ++ typScms ++ "." ++ Types.name typs)
+    types <- mapM getType' rows
     return (types, notNullIdxs)
 
 driverSQLServer :: IConnection conn => Driver conn