{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}
module Database.MSSQLServer.Query.RpcResponseSet ( RpcResponseSet (..)
, RpcResponse (..)
, RpcResultSet (..)
, RpcResult (..)
, RpcOutputSet (..)
) where
import Control.Applicative(Alternative((<|>)),many,(<$>))
import Database.Tds.Message
import Database.MSSQLServer.Query.Row
import Database.MSSQLServer.Query.Only
import Database.MSSQLServer.Query.TokenStreamParser
import Database.MSSQLServer.Query.Template
import Control.Monad(forM)
import Language.Haskell.TH (runIO,pprint)
#if MIN_VERSION_mtl(2,2,1)
import Control.Monad.Except
#else
import Control.Monad.Error
runExceptT = runErrorT
#endif
errorDone :: Parser TokenStream
errorDone :: Parser TokenStream
errorDone = do
[TokenStream]
_ <- Parser TokenStream -> Parser [TokenStream]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser TokenStream -> Parser [TokenStream])
-> Parser TokenStream -> Parser [TokenStream]
forall a b. (a -> b) -> a -> b
$ (TokenStream -> Bool) -> Parser TokenStream
satisfy ((TokenStream -> Bool) -> Parser TokenStream)
-> (TokenStream -> Bool) -> Parser TokenStream
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> (TokenStream -> Bool) -> TokenStream -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TokenStream -> Bool
isTSError
TokenStream
ts <- (TokenStream -> Bool) -> Parser TokenStream
satisfy TokenStream -> Bool
isTSError
[TokenStream]
_ <- Parser TokenStream -> Parser [TokenStream]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser TokenStream -> Parser [TokenStream])
-> Parser TokenStream -> Parser [TokenStream]
forall a b. (a -> b) -> a -> b
$ (TokenStream -> Bool) -> Parser TokenStream
satisfy ((TokenStream -> Bool) -> Parser TokenStream)
-> (TokenStream -> Bool) -> Parser TokenStream
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> (TokenStream -> Bool) -> TokenStream -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TokenStream -> Bool
isFinalTSDoneProc
TokenStream
_ <- (TokenStream -> Bool) -> Parser TokenStream
satisfy TokenStream -> Bool
isFinalTSDoneProc
TokenStream -> Parser TokenStream
forall (m :: * -> *) a. Monad m => a -> m a
return TokenStream
ts
trySatisfy :: (TokenStream -> Bool) -> Parser' TokenStream
trySatisfy :: (TokenStream -> Bool) -> Parser' TokenStream
trySatisfy TokenStream -> Bool
f = do
TokenStream
ts <- Parser TokenStream -> Parser' TokenStream
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Parser TokenStream -> Parser' TokenStream)
-> Parser TokenStream -> Parser' TokenStream
forall a b. (a -> b) -> a -> b
$ ((TokenStream -> Bool) -> Parser TokenStream
satisfyNotError TokenStream -> Bool
f) Parser TokenStream -> Parser TokenStream -> Parser TokenStream
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser TokenStream
errorDone
case TokenStream
ts of
TSError Info
ei -> Info -> Parser' TokenStream
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Info
ei
TokenStream
_ -> TokenStream -> Parser' TokenStream
forall (m :: * -> *) a. Monad m => a -> m a
return TokenStream
ts
trySatisfyMany :: (TokenStream -> Bool) -> Parser' [TokenStream]
trySatisfyMany :: (TokenStream -> Bool) -> Parser' [TokenStream]
trySatisfyMany TokenStream -> Bool
f = do
[TokenStream]
tss <- Parser [TokenStream] -> Parser' [TokenStream]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Parser [TokenStream] -> Parser' [TokenStream])
-> Parser [TokenStream] -> Parser' [TokenStream]
forall a b. (a -> b) -> a -> b
$ (Parser TokenStream -> Parser [TokenStream]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser TokenStream -> Parser [TokenStream])
-> Parser TokenStream -> Parser [TokenStream]
forall a b. (a -> b) -> a -> b
$ (TokenStream -> Bool) -> Parser TokenStream
satisfyNotError TokenStream -> Bool
f) Parser [TokenStream]
-> Parser [TokenStream] -> Parser [TokenStream]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((\TokenStream
x->[TokenStream
x]) (TokenStream -> [TokenStream])
-> Parser TokenStream -> Parser [TokenStream]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser TokenStream
errorDone)
case [TokenStream]
tss of
(TSError Info
ei):[TokenStream]
_ -> Info -> Parser' [TokenStream]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Info
ei
[TokenStream]
_ -> [TokenStream] -> Parser' [TokenStream]
forall (m :: * -> *) a. Monad m => a -> m a
return [TokenStream]
tss
listOfRow :: Row a => Parser' ([a])
listOfRow :: Parser' [a]
listOfRow = do
[TokenStream]
_ <- (TokenStream -> Bool) -> Parser' [TokenStream]
trySatisfyMany ((TokenStream -> Bool) -> Parser' [TokenStream])
-> (TokenStream -> Bool) -> Parser' [TokenStream]
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> (TokenStream -> Bool) -> TokenStream -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TokenStream -> Bool
isTSColMetaData
TokenStream
tsCmd <- (TokenStream -> Bool) -> Parser' TokenStream
trySatisfy TokenStream -> Bool
isTSColMetaData
[TokenStream]
_ <- (TokenStream -> Bool) -> Parser' [TokenStream]
trySatisfyMany ((TokenStream -> Bool) -> Parser' [TokenStream])
-> (TokenStream -> Bool) -> Parser' [TokenStream]
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> (TokenStream -> Bool) -> TokenStream -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TokenStream -> Bool
isTSRow
[TokenStream]
tsRows <- (TokenStream -> Bool) -> Parser' [TokenStream]
trySatisfyMany TokenStream -> Bool
isTSRow
[TokenStream]
_ <- (TokenStream -> Bool) -> Parser' [TokenStream]
trySatisfyMany ((TokenStream -> Bool) -> Parser' [TokenStream])
-> (TokenStream -> Bool) -> Parser' [TokenStream]
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> (TokenStream -> Bool) -> TokenStream -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TokenStream -> Bool
isTSDoneInProc
TokenStream
_ <- (TokenStream -> Bool) -> Parser' TokenStream
trySatisfy TokenStream -> Bool
isTSDoneInProc
[a] -> Parser' [a]
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> Parser' [a]) -> [a] -> Parser' [a]
forall a b. (a -> b) -> a -> b
$
let
(TSColMetaData (Maybe ColMetaData
maybeCmd)) = TokenStream
tsCmd
mcds :: [MetaColumnData]
mcds = case (\(ColMetaData [MetaColumnData]
x) -> [MetaColumnData]
x) (ColMetaData -> [MetaColumnData])
-> Maybe ColMetaData -> Maybe [MetaColumnData]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ColMetaData
maybeCmd of
Maybe [MetaColumnData]
Nothing -> [Char] -> [MetaColumnData]
forall a. HasCallStack => [Char] -> a
error [Char]
"listOfRow: ColMetaData is necessary"
Just [MetaColumnData]
mcds' -> [MetaColumnData]
mcds'
rows :: [[RawBytes]]
rows = (\(TSRow [RowColumnData]
row) -> RowColumnData -> RawBytes
getRawBytes (RowColumnData -> RawBytes) -> [RowColumnData] -> [RawBytes]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RowColumnData]
row) (TokenStream -> [RawBytes]) -> [TokenStream] -> [[RawBytes]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TokenStream]
tsRows
in [MetaColumnData] -> [RawBytes] -> a
forall a. Row a => [MetaColumnData] -> [RawBytes] -> a
fromListOfRawBytes [MetaColumnData]
mcds ([RawBytes] -> a) -> [[RawBytes]] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[RawBytes]]
rows
where
isTSColMetaData :: TokenStream -> Bool
isTSColMetaData :: TokenStream -> Bool
isTSColMetaData (TSColMetaData{}) = Bool
True
isTSColMetaData TokenStream
_ = Bool
False
isTSRow :: TokenStream -> Bool
isTSRow :: TokenStream -> Bool
isTSRow (TSRow{}) = Bool
True
isTSRow TokenStream
_ = Bool
False
isTSDoneInProc :: TokenStream -> Bool
isTSDoneInProc :: TokenStream -> Bool
isTSDoneInProc (TSDoneInProc{}) = Bool
True
isTSDoneInProc TokenStream
_ = Bool
False
getRawBytes :: RowColumnData -> RawBytes
getRawBytes :: RowColumnData -> RawBytes
getRawBytes (RCDOrdinal RawBytes
dt) = RawBytes
dt
getRawBytes (RCDLarge Maybe TextPointer
_ Maybe TimeStamp
_ RawBytes
dt) = RawBytes
dt
class RpcResultSet a where
rpcResultSetParser :: Parser' a
instance RpcResultSet () where
rpcResultSetParser :: Parser' ()
rpcResultSetParser = () -> Parser' ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
instance (Row a) => RpcResultSet [a] where
rpcResultSetParser :: Parser' [a]
rpcResultSetParser = Parser' [a]
forall a. Row a => Parser' [a]
listOfRow