mssql-simple 0.5.0.1 → 0.6.0.0

raw patch · 7 files changed

+312/−124 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• mssql-simple.cabal +2/−2
• src/Database/MSSQLServer/Query.hs +109/−39
• src/Database/MSSQLServer/Query/ResultSet.hs +114/−35
• src/Database/MSSQLServer/Query/RpcQuerySet.hs +2/−0
• src/Database/MSSQLServer/Query/RpcResponseSet.hs +38/−17
• src/Database/MSSQLServer/Query/Template.hs +4/−2
• src/Database/MSSQLServer/Query/TokenStreamParser.hs +43/−29

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: e2009f3f703bbefbce95e2f4d5d870bab30e35886b962643c3bacda549dc8c78+-- hash: c3913c68161411cf5ad4ae9ffcd5fa5e963bb712ac24926d73e96499a6f44b94  name:           mssql-simple-version:        0.5.0.1+version:        0.6.0.0 synopsis:       SQL Server client library implemented in Haskell description:    Please see the README on GitHub at <https://github.com/mitsuji/mssql-simple#readme> category:       Database

@@ -4,12 +4,15 @@ -- | -- SQL Server client library implemented in Haskell --+-- 'sql' function is useful for execution of plain sql text.+-- Also 'rpc' function is useful for stored procedure RPC with input/output parameters.+-- -- [Usage Example](https://github.com/mitsuji/mssql-simple-example/blob/master/app/Main.hs)   module Database.MSSQLServer.Query (                                   -- * SQL Text Query-                                  -- $use+                                  -- $use_sql                                     sql                                                                        -- ** ResultSet@@ -21,6 +24,7 @@                                   , ReturnStatus (..)                                                                      -- * RPC Query+                                  -- $use_rpc                                   , rpc                                                                      -- ** RpcResponseSet@@ -41,6 +45,7 @@                                   , RpcParam (..)                                   , RpcParamName +                                  -- ** Helpers for passing parameters                                   , bitVal                                   , tinyintVal                                   , smallintVal@@ -209,7 +214,7 @@   --- $use+-- $use_sql -- A 'sql' function accepts valid 'Connection' and SQL text. -- And the expression could be evaluated as a instance of 'ResultSet' type class. --@@ -222,31 +227,21 @@ -- > import Database.MSSQLServer.Connection -- > import Database.MSSQLServer.Query -- >--- > query_select1 :: Connection -> IO Int--- > query_select1 conn = do+-- > sql_select1 :: Connection -> IO Int+-- > sql_select1 conn = do -- >     [Only i] <- sql conn "SELECT 2 + 2" :: IO [Only Int] -- >     return i -- -- In SQL , uncomputable expression could be evaluated as NULL. -- In that case, 'Maybe' type could be used. ----- > {-# LANGUAGE OverloadedStrings #-}--- >--- > import Database.MSSQLServer.Connection--- > import Database.MSSQLServer.Query--- >--- > query_select2 :: Connection -> IO (Maybe Int)--- > query_select2 conn = do+-- > sql_select2 :: Connection -> IO (Maybe Int)+-- > sql_select2 conn = do -- >     [Only mi] <- sql conn "SELECT 6 / 2" :: IO [Only (Maybe Int)] -- >     return mi ----- > {-# LANGUAGE OverloadedStrings #-}--- >--- > import Database.MSSQLServer.Connection--- > import Database.MSSQLServer.Query--- >--- > query_select3 :: Connection -> IO (Maybe Int)--- > query_select3 conn = do+-- > sql_select3 :: Connection -> IO (Maybe Int)+-- > sql_select3 conn = do -- >     [Only mi] <- sql conn "SELECT 6 / 0" :: IO [Only (Maybe Int)] -- >     return mi --@@ -263,21 +258,13 @@ -- > import Database.Tds.Message -- > import Data.Time (UTCTime(..)) -- >--- > query_select4 :: Connection -> IO [(Int,String,LT.Text,Money,UTCTime,Maybe UTCTime,Maybe UTCTime)]--- > query_select4 conn = sql conn "SELECT * FROM TSome ORDER BY somePrice"+-- > sql_select4 :: Connection -> IO [(Int,String,LT.Text,Money,UTCTime,Maybe UTCTime,Maybe UTCTime)]+-- > sql_select4 conn = sql conn "SELECT * FROM TSome ORDER BY somePrice" -- -- Any type could be a instance of 'Row' and used as the result of select query as follows. ----- > {-# LANGUAGE OverloadedStrings #-} -- > {-# LANGUAGE BangPatterns #-} -- >--- > import Database.MSSQLServer.Connection--- > import Database.MSSQLServer.Query--- >--- > import qualified Data.Text.Lazy as LT--- > import Database.Tds.Message--- > import Data.Time (UTCTime(..))--- > -- > data Some = Some { someID :: Int -- >                  , someTitle :: LT.Text -- >                  , someContent :: LT.Text@@ -304,29 +291,29 @@ -- > -- >   fromListOfRawBytes _ _ = error "fromListOfRawBytes: List length must be 7" -- >--- > query_select5 :: Connection -> IO [Some]--- > query_select5 conn = sql conn "SELECT TOP 10 * FROM TSome ORDER BY somePrice DESC"+-- > sql_select5 :: Connection -> IO [Some]+-- > sql_select5 conn = sql conn "SELECT TOP 10 * FROM TSome ORDER BY somePrice DESC" -- -- 'Row' is also a instance of 'Result' and tuple of 'Result' is a instance of 'ResultSet'. -- So the result of multiple SQL query could be obtained simultaneously as follows. -- -- > import Data.Monoid (mconcat) -- >--- > query_select6 :: Connection -> IO ([Some],[Some])--- > query_select6 conn =+-- > sql_select6 :: Connection -> IO ([Some],[Some])+-- > sql_select6 conn = -- >   sql conn $ mconcat ["SELECT * FROM TSome WHERE someID < 8 ORDER BY someID;", -- >                       "SELECT * FROM TSome WHERE 8 <= someID AND someID < 12 ORDER BY someID DESC;"] -- -- 'RowCount' is a instance of 'ResultSet'.--- So the count of SQL table record affected with the SQL query could be obtainde as follows.+-- So the count of SQL table record affected with the SQL query could be obtained as follows. -- -- > {-# LANGUAGE OverloadedStrings #-} -- > -- > import Database.MSSQLServer.Connection -- > import Database.MSSQLServer.Query -- >--- > query_count1 :: Connection -> IO Int--- > query_count1 conn = do+-- > sql_count1 :: Connection -> IO Int+-- > sql_count1 conn = do -- >   RowCount rc <- sql conn "UPDATE TSome SET somePrice = somePrice + 100 WHERE someID < 5" -- >   return rc --@@ -338,9 +325,58 @@ -- > import Database.MSSQLServer.Connection -- > import Database.MSSQLServer.Query -- >--- > query_discard1 :: Connection -> IO ()--- > query_discard1 conn = sql conn "UPDATE TSome SET somePrice = somePrice + 100 WHERE someID < 5"+-- > sql_discard1 :: Connection -> IO ()+-- > sql_discard1 conn = sql conn "UPDATE TSome SET somePrice = somePrice + 100 WHERE someID < 5" --+-- Even DROP/CREATE TABLE statement could be executed as follows when your account has privileges.+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > {-# LANGUAGE QuasiQuotes #-}+-- >+-- > import Database.MSSQLServer.Connection+-- > import Database.MSSQLServer.Query+-- > import Text.RawString.QQ (r)+-- >+-- > sql_create_table1 :: Connection -> IO ()+-- > sql_create_table1 conn = do+-- >   sql conn "DROP TABLE TSome" :: IO ()+-- >   sql conn [r|+-- > CREATE TABLE TSome (+-- > 	someID int IDENTITY(1,1) NOT NULL,+-- > 	someTitle nvarchar(40) NOT NULL,+-- > 	someContent ntext NOT NULL,+-- > 	somePrice money NOT NULL,+-- > 	someCreated datetime NOT NULL,+-- > 	someModified datetime NULL,+-- > 	someDeleted datetime NULL,+-- >+-- > 	CONSTRAINT PK_TSome PRIMARY KEY CLUSTERED (+-- > 		someID ASC+-- > 	)+-- > 	WITH (+-- > 		PAD_INDEX  = OFF,+-- > 		STATISTICS_NORECOMPUTE  = OFF,+-- > 		IGNORE_DUP_KEY = OFF,+-- > 		ALLOW_ROW_LOCKS  = ON,+-- > 		ALLOW_PAGE_LOCKS  = ON+-- > 	) ON [PRIMARY]+-- >+-- > ) ON [PRIMARY] TEXTIMAGE_ON [PRIMARY]+-- > |]+--+-- INSERT batch could be executed within transaction as follows.+--+-- > sql_insert1 :: Connection -> IO ()+-- > sql_insert1 conn = sql conn [r|+-- > BEGIN TRAN;+-- > INSERT INTO TSome(someTitle,someContent,somePrice,someCreated) VALUES('title','content',12345.60,GETDATE());+-- > INSERT INTO TSome(someTitle,someContent,somePrice,someCreated) VALUES('title','content',12345.60,GETDATE());+-- > INSERT INTO TSome(someTitle,someContent,somePrice,someCreated) VALUES('title','content',12345.60,GETDATE());+-- > INSERT INTO TSome(someTitle,someContent,somePrice,someCreated) VALUES('title','content',12345.60,GETDATE());+-- > COMMIT TRAN;+-- > |]+-- >+-- -- 'ReturnStatus' is a instance of 'ResultSet'. -- So when a stored procedure executed in SQL text, Return status of the execution could be obtained as follows. --@@ -349,7 +385,41 @@ -- > import Database.MSSQLServer.Connection -- > import Database.MSSQLServer.Query -- >--- > query_status1 :: Connection -> IO Int--- > query_status1 conn = do+-- > sql_status1 :: Connection -> IO Int+-- > sql_status1 conn = do -- >   ReturnStatus rets <- sql conn "EXEC SP_Input1 @Val1=3" -- >   return rets+++-- $use_rpc+-- Stored procedure RPC could be executed as follows.+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- >+-- > import Database.MSSQLServer.Connection+-- > import Database.MSSQLServer.Query+-- >+-- > import qualified Data.Text as T+-- > import Data.Word (Word16)+-- >+-- > rpc_sql_select1 :: Connection -> IO (RpcResponse () [Some])+-- > rpc_sql_select1 conn = rpc conn $+-- >                        RpcQuery ("sp_executesql"::T.Text) $ nvarcharVal "" (Just "SELECT * FROM TSome")+--+-- There several ways provided for specify stored procedures.+-- See ProcID section of [\[MS-TDS\] 2.2.6.6 RPC Request](https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/619c43b6-9495-4a58-9e49-a4950db245b3).+--+-- > rpc_sql_select2 :: Connection -> Int -> IO (RpcResponse () [Some])+-- > rpc_sql_select2 conn max = rpc conn $ RpcQuery SP_ExecuteSql+-- >                            ( nvarcharVal "" (Just "SELECT * FROM TSome WHERE someID < @Max")+-- >                            , nvarcharVal "" (Just "@Max Int")+-- >                            , intVal "" (Just max)+-- >                            )+--+-- > rpc_sql_select3 :: Connection -> Int -> Int -> IO (RpcResponse () [Some])+-- > rpc_sql_select3 conn min max = rpc conn $ RpcQuery (0xa::Word16)+-- >                                ( nvarcharVal "" (Just "SELECT * FROM TSome WHERE @Min < someID AND someID < @Max")+-- >                                , nvarcharVal "" (Just "@Min Int, @Max Int")+-- >                                , intVal "@Min" (Just min)+-- >                                , intVal "@Max" (Just max)+-- >                                )

@@ -9,7 +9,7 @@                                             ) where  -import Control.Applicative ((<$>))+import Control.Applicative(Alternative((<|>)),many,(<$>)) import Database.Tds.Message import Database.MSSQLServer.Query.Row import Database.MSSQLServer.Query.Only@@ -26,49 +26,113 @@ #endif  +errorDone :: Parser TokenStream+errorDone = do+  _  <- many $ satisfy $ not . isTSError+  ts <- satisfy isTSError+  _  <- many $ satisfy $ not . isTSDoneOrDoneProc -- [MEMO] skip Info+  _  <- satisfy isFinalTSDoneOrDoneProc+  return ts+  where+    isTSError :: TokenStream -> Bool+    isTSError (TSError{}) = True+    isTSError _ = False -noResult :: Parser' ()-noResult = do++trySatisfy :: (TokenStream -> Bool) -> Parser' TokenStream+trySatisfy f = do+  ts <- lift $ (satisfyNotError f) <|> errorDone+  case ts of+    TSError ei -> throwError ei+    _ -> return ts++trySatisfyMany :: (TokenStream -> Bool) -> Parser' [TokenStream]+trySatisfyMany f = do+  tss <- lift $ (many $ satisfyNotError f) <|> ((\x->[x]) <$> errorDone)+  case tss of+    (TSError ei):_ -> throwError ei+    _ -> return tss++++noResultDone :: Parser' ()+noResultDone = do   _ <- trySatisfyMany $ not . isTSDoneOrDoneProc   _ <- trySatisfy isTSDoneOrDoneProc   return ()-  where-    isTSDoneOrDoneProc :: TokenStream -> Bool-    isTSDoneOrDoneProc (TSDone{}) = True-    isTSDoneOrDoneProc (TSDoneProc{}) = True-    isTSDoneOrDoneProc _ = False +noResultFinalDone :: Parser' ()+noResultFinalDone = do+  _ <- trySatisfyMany $ not . isFinalTSDoneOrDoneProc+  _ <- trySatisfy isFinalTSDoneOrDoneProc+  return () +noResultFinalDone' :: Parser' ()+noResultFinalDone' = do+  _ <- trySatisfyMany $ not . isTSDoneOrDoneProc+  _ <- trySatisfy isFinalTSDoneOrDoneProc+  return ()+++ returnStatus :: Parser' ReturnStatus returnStatus = do   _ <- trySatisfyMany $ not . isTSReturnStatus   TSReturnStatus rets <- trySatisfy isTSReturnStatus-  _ <- trySatisfy isTSDoneProc   return $ ReturnStatus $ fromIntegral rets   where     isTSReturnStatus :: TokenStream -> Bool     isTSReturnStatus (TSReturnStatus{}) = True     isTSReturnStatus _ = False -    isTSDoneProc :: TokenStream -> Bool-    isTSDoneProc (TSDoneProc{}) = True-    isTSDoneProc _ = False+returnStatusDone :: Parser' ReturnStatus+returnStatusDone = do+  rets <- returnStatus+  _ <- trySatisfyMany $ not . isTSDoneProc -- [MEMO] skip ReturnValue+  _ <- trySatisfy isTSDoneProc+  return rets +returnStatusFinalDone :: Parser' ReturnStatus+returnStatusFinalDone = do+  rets <- returnStatus+  _ <- trySatisfyMany $ not . isFinalTSDoneProc -- [MEMO] skip ReturnValue+  _ <- trySatisfy isFinalTSDoneProc+  return rets -rowCount :: Parser' RowCount-rowCount = do+returnStatusFinalDone' :: Parser' ReturnStatus+returnStatusFinalDone' = do+  rets <- returnStatus+  _ <- trySatisfyMany $ not . isTSDoneProc -- [MEMO] skip ReturnValue+  _ <- trySatisfy isFinalTSDoneProc+  return rets++++rowCountDone :: Parser' RowCount+rowCountDone = do   _ <- trySatisfyMany $ not . isTSDone   TSDone (Done _ _ rc) <- trySatisfy isTSDone   return $ RowCount $ fromIntegral rc +rowCountFinalDone :: Parser' RowCount+rowCountFinalDone = do+  _ <- trySatisfyMany $ not . isFinalTSDone+  TSDone (Done _ _ rc) <- trySatisfy isFinalTSDone+  return $ RowCount $ fromIntegral rc +rowCountFinalDone' :: Parser' RowCount+rowCountFinalDone' = do+  _ <- trySatisfyMany $ not . isTSDone+  TSDone (Done _ _ rc) <- trySatisfy isFinalTSDone+  return $ RowCount $ fromIntegral rc+++ listOfRow :: Row a => Parser' ([a]) listOfRow = do   tsCmd <- trySatisfy isTSColMetaData-  _ <- trySatisfyMany $ not . isTSRow+  _ <- trySatisfyMany $ not . isTSRow -- [MEMO] skip Order   tsRows <- trySatisfyMany isTSRow-  _ <- trySatisfyMany $ not . isTSDone -- necesarry ?-  _ <- trySatisfy $ isTSDone   return $     let       (TSColMetaData (maybeCmd)) = tsCmd@@ -91,15 +155,26 @@     getRawBytes (RCDOrdinal dt) = dt     getRawBytes (RCDLarge _ _ dt) = dt ---isTSDone :: TokenStream -> Bool-isTSDone (TSDone{}) = True-isTSDone _ = False--+listOfRowDone :: Row a => Parser' ([a])+listOfRowDone = do+  rs <- listOfRow+  _ <- trySatisfyMany $ not . isTSDone -- [MEMO] necesarry ?+  _ <- trySatisfy $ isTSDone+  return rs +listOfRowFinalDone :: Row a => Parser' ([a])+listOfRowFinalDone = do+  rs <- listOfRow+  _ <- trySatisfyMany $ not . isFinalTSDone -- [MEMO] necesarry ?+  _ <- trySatisfy $ isFinalTSDone+  return rs +listOfRowFinalDone' :: Row a => Parser' ([a])+listOfRowFinalDone' = do+  rs <- listOfRow+  _ <- trySatisfyMany $ not . isTSDone -- [MEMO] necesarry ?+  _ <- trySatisfy $ isFinalTSDone+  return rs   @@ -108,16 +183,16 @@   instance ResultSet () where-  resultSetParser = noResult+  resultSetParser = noResultFinalDone  instance ResultSet RowCount where-  resultSetParser = rowCount+  resultSetParser = rowCountFinalDone  instance ResultSet ReturnStatus where-  resultSetParser = returnStatus+  resultSetParser = returnStatusFinalDone  instance (Row a) => ResultSet [a] where-  resultSetParser = listOfRow+  resultSetParser = listOfRowFinalDone   @@ -128,25 +203,29 @@   return dec --instance (Result a1, Result a2) => ResultSet (a1, a2) where --  resultSetParser = do---    !r1 <- resultParser :: (Result a1) => Parser' a1---    !r2 <- resultParser :: (Result a2) => Parser' a2+--    !r1 <- resultParser False :: (Result a1) => Parser' a1+--    !r2 <- resultParser True :: (Result a2) => Parser' a2 --    return  (r1,r2) --   class Result a where-  resultParser :: Parser' a+  resultParser :: Bool -> Parser' a -- [MEMO] 1st param: isFinal  instance Result () where-  resultParser = noResult+  resultParser True = noResultFinalDone'+  resultParser _ = noResultDone  instance Result RowCount where-  resultParser = rowCount+  resultParser True = rowCountFinalDone'+  resultParser _ = rowCountDone  instance Result ReturnStatus where-  resultParser = returnStatus+  resultParser True = returnStatusFinalDone'+  resultParser _ = returnStatusDone  instance Row a => Result [a] where-  resultParser = listOfRow+  resultParser True = listOfRowFinalDone'+  resultParser _ = listOfRowDone  

@@ -112,6 +112,8 @@ data RpcQuery a b = RpcQuery !a !b                   deriving (Show) +-- | There several ways provided for specify stored procedures.+-- See ProcID section of [\[MS-TDS\] 2.2.6.6 RPC Request](https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/619c43b6-9495-4a58-9e49-a4950db245b3). class RpcQueryId a where   toRpcReqBatch :: (RpcParamSet b) => a -> b -> RpcReqBatch 

@@ -11,7 +11,8 @@                                                  , RpcOutputSet (..)                                                  ) where -import Control.Applicative((<$>))++import Control.Applicative(Alternative((<|>)),many,(<$>)) import Database.Tds.Message import Database.MSSQLServer.Query.Row import Database.MSSQLServer.Query.Only@@ -29,14 +30,37 @@ #endif  +errorDone :: Parser TokenStream+errorDone = do+  _  <- many $ satisfy $ not . isTSError+  ts <- satisfy isTSError+  _  <- many $ satisfy $ not . isFinalTSDoneProc+  _  <- satisfy isFinalTSDoneProc+  return ts +trySatisfy :: (TokenStream -> Bool) -> Parser' TokenStream+trySatisfy f = do+  ts <- lift $ (satisfyNotError f) <|> errorDone+  case ts of+    TSError ei -> throwError ei+    _ -> return ts++trySatisfyMany :: (TokenStream -> Bool) -> Parser' [TokenStream]+trySatisfyMany f = do+  tss <- lift $ (many $ satisfyNotError f) <|> ((\x->[x]) <$> errorDone)+  case tss of+    (TSError ei):_ -> throwError ei+    _ -> return tss+++ listOfRow :: Row a => Parser' ([a]) listOfRow = do   _ <- trySatisfyMany $ not . isTSColMetaData   tsCmd <- trySatisfy isTSColMetaData-  _ <- trySatisfyMany $ not . isTSRow+  _ <- trySatisfyMany $ not . isTSRow -- [MEMO] skip Order   tsRows <- trySatisfyMany isTSRow-  _ <- trySatisfyMany  $ not . isTSDoneInProc -- necesarry ?+  _ <- trySatisfyMany  $ not . isTSDoneInProc -- [MEMO] necesarry ?   _ <- trySatisfy isTSDoneInProc   return $     let@@ -143,17 +167,18 @@                    deriving (Show)  -rpcResponseParser :: (RpcOutputSet a, RpcResultSet b) => Parser (RpcResponse a b)-rpcResponseParser = do+rpcResponseParser :: (RpcOutputSet a, RpcResultSet b) => Bool -> Parser (RpcResponse a b)+rpcResponseParser final = do   let rrParser = runExceptT $ do         rrs <- rpcResultSetParser-        _ <- trySatisfyMany $ not . isTSReturnStatus+        _ <- trySatisfyMany $ not . isTSReturnStatus -- [MEMO] necesarry ?         TSReturnStatus ret <- trySatisfy isTSReturnStatus-        _ <- trySatisfyMany $ not . isTSReturnValue+        _ <- trySatisfyMany $ not . isTSReturnValue -- [MEMO] necesarry ?         rvs <- trySatisfyMany isTSReturnValue-        _ <- trySatisfyMany $ not . isTSDoneProc-        _ <- trySatisfy isTSDoneProc-+        _ <- trySatisfyMany $ not . isTSDoneProc -- [MEMO] necesarry ?+        _ <- if final+             then trySatisfy isFinalTSDoneProc+             else trySatisfy isTSDoneProc         let rvs' = (\(TSReturnValue rv) -> rv) <$>  rvs         return $ RpcResponse (fromIntegral ret) (fromReturnValues rvs') rrs   err <- rrParser@@ -170,19 +195,15 @@     isTSReturnValue (TSReturnValue{}) = True     isTSReturnValue _ = False -    isTSDoneProc :: TokenStream -> Bool-    isTSDoneProc (TSDoneProc{}) = True-    isTSDoneProc _ = False    - class RpcResponseSet a where   rpcResponseSetParser :: Parser a  instance (RpcOutputSet a1, RpcResultSet b1) => RpcResponseSet (RpcResponse a1 b1) where-  rpcResponseSetParser = rpcResponseParser+  rpcResponseSetParser = rpcResponseParser True  -- [MEMO] using Template Haskell forM [2..30] $ \n -> do@@ -191,8 +212,8 @@   return dec --instance (RpcOutputSet a1, RpcResultSet b1, RpcOutputSet a2, RpcResultSet b2) => RpcResponseSet (RpcResponse a1 b1, RpcResponse a2 b2) where --  rpcResponseSetParser = do---    !r1 <- rpcResponseParser---    !r2 <- rpcResponseParser+--    !r1 <- rpcResponseParser False+--    !r2 <- rpcResponseParser True --    return (r1,r2) -- 

@@ -84,7 +84,8 @@                  (flip map [1..n] $ \i ->                      BindS                      (BangP (VarP (mkName $ "r" <> show i )))-                     (SigE (VarE (mkName "resultParser"))+                     (SigE+                      (AppE (VarE (mkName "resultParser")) (if i==n then (ConE 'True) else (ConE 'False)) )                       (ForallT                         [PlainTV (mkName $ "a" <> show i)] #if MIN_VERSION_template_haskell(2,10,0)@@ -131,7 +132,8 @@                (                  (flip map [1..n] $ \i ->                      BindS-                     (BangP (VarP (mkName $ "r" <> show i ))) (VarE (mkName "rpcResponseParser"))+                     (BangP (VarP (mkName $ "r" <> show i )))+                     (AppE (VarE (mkName "rpcResponseParser")) (if i==n then (ConE 'True) else (ConE 'False)))                  )                  <>                  [(NoBindS (AppE (VarE 'return) (TupE (map (\i->VarE (mkName $ "r" <> show i)) [1..n]) )) )]

@@ -6,12 +6,17 @@                                                     , satisfy                                                     , satisfyNotError                                                     , Parser'(..)-                                                    , trySatisfy-                                                    , trySatisfyMany+                                                    , isTSError+                                                    , isTSDoneOrDoneProc+                                                    , isTSDone+                                                    , isTSDoneProc+                                                    , isFinalTSDoneOrDoneProc+                                                    , isFinalTSDone+                                                    , isFinalTSDoneProc                                                     ) where  -import Control.Applicative(Applicative((<*>),pure),Alternative((<|>),empty),many,(<$>))+import Control.Applicative(Applicative((<*>),pure),Alternative((<|>),empty),(<$>)) import Control.Monad(Monad(..),MonadPlus(..),ap) import Data.Monoid ((<>),mconcat) #if MIN_VERSION_base(4,9,0)@@ -21,7 +26,9 @@ import Database.Tds.Message import Database.MSSQLServer.Query.Row +import Data.Bits ((.&.)) + #if MIN_VERSION_mtl(2,2,1) import Control.Monad.Except #else@@ -85,36 +92,43 @@ #endif  -trySatisfy :: (TokenStream -> Bool) -> Parser' TokenStream-trySatisfy f = do-  ts <- lift $ (satisfyNotError f) <|> errorDone-  case ts of-    TSError ei -> throwError ei-    _ -> return ts+isTSError :: TokenStream -> Bool+isTSError (TSError{}) = True+isTSError _ = False -trySatisfyMany :: (TokenStream -> Bool) -> Parser' [TokenStream]-trySatisfyMany f = do-  tss <- lift $ (many $ satisfyNotError f) <|> ((\x->[x]) <$> errorDone)-  case tss of-    (TSError ei):_ -> throwError ei-    _ -> return tss+isTSDoneOrDoneProc :: TokenStream -> Bool+isTSDoneOrDoneProc (TSDone{}) = True+isTSDoneOrDoneProc (TSDoneProc{}) = True+isTSDoneOrDoneProc _ = False +isTSDone :: TokenStream -> Bool+isTSDone (TSDone{}) = True+isTSDone _ = False -errorDone :: Parser TokenStream-errorDone = do-  _  <- many $ satisfy $ not . isTSError-  ts <- satisfy isTSError-  _  <- many $ satisfy $ not . isTSDoneOrDoneProc-  _  <- satisfy isTSDoneOrDoneProc-  return ts+isTSDoneProc :: TokenStream -> Bool+isTSDoneProc (TSDoneProc{}) = True+isTSDoneProc _ = False+++isFinalTSDoneOrDoneProc :: TokenStream -> Bool+isFinalTSDoneOrDoneProc = (||) <$> isFinalTSDone <*> isFinalTSDoneProc++isFinalTSDone :: TokenStream -> Bool+isFinalTSDone = f   where-    isTSDoneOrDoneProc :: TokenStream -> Bool-    isTSDoneOrDoneProc (TSDone{}) = True-    isTSDoneOrDoneProc (TSDoneProc{}) = True-    isTSDoneOrDoneProc _ = False+    f :: TokenStream -> Bool+    f (TSDone x) = isFinalDone x+    f _ = False -isTSError :: TokenStream -> Bool-isTSError (TSError{}) = True-isTSError _ = False+isFinalTSDoneProc :: TokenStream -> Bool+isFinalTSDoneProc = f+  where+    f :: TokenStream -> Bool+    f (TSDoneProc x) = isFinalDone x+    f _ = False++isFinalDone :: Done -> Bool+isFinalDone (Done st _ _) = not $ st .&. 0x01 == 0x01 -- [MEMO] 0x01 more bit+