{-# 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 -- [MEMO] skip Order
  [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 -- [MEMO] necesarry ?
  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


-- [MEMO] using Template Haskell
forM [2..30] $ \n -> do
  dec <- rpcResultSetTupleQ n
--  runIO $ putStrLn $ pprint dec
  return dec
--instance (RpcResult a1, RpcResult a2) => RpcResultSet (a1, a2) where
--  rpcResultSetParser = do
--    !r1 <- rpcResultParser :: (RpcResult a1) => Parser' a1
--    !r2 <- rpcResultParser :: (RpcResult a2) => Parser' a2
--    return  (r1,r2)
--


class RpcResult a where
  rpcResultParser :: Parser' a

instance Row a => RpcResult [a] where
  rpcResultParser :: Parser' [a]
rpcResultParser = Parser' [a]
forall a. Row a => Parser' [a]
listOfRow

  



rvTypeInfo :: ReturnValue -> TypeInfo
rvTypeInfo :: ReturnValue -> TypeInfo
rvTypeInfo (ReturnValue RVParamOrdinal
_ RVParamName
_ RVStatus
_ RVParamOrdinal
_ RVParamOrdinal
_ TypeInfo
ti RawBytes
_) = TypeInfo
ti

rvRawBytes :: ReturnValue -> RawBytes
rvRawBytes :: ReturnValue -> RawBytes
rvRawBytes (ReturnValue RVParamOrdinal
_ RVParamName
_ RVStatus
_ RVParamOrdinal
_ RVParamOrdinal
_ TypeInfo
_ RawBytes
rb) = RawBytes
rb


class RpcOutputSet a where
  fromReturnValues :: [ReturnValue] -> a

instance RpcOutputSet () where
  fromReturnValues :: [ReturnValue] -> ()
fromReturnValues [] = ()
  fromReturnValues [ReturnValue]
_ = [Char] -> ()
forall a. HasCallStack => [Char] -> a
error [Char]
"fromReturnValues: List length must be 0"
  
instance (Data a) => RpcOutputSet (Only a) where
  fromReturnValues :: [ReturnValue] -> Only a
fromReturnValues [ReturnValue
r1] = a -> Only a
forall a. a -> Only a
Only a
d1
    where
      !d1 :: a
d1 = TypeInfo -> RawBytes -> a
forall a. Data a => TypeInfo -> RawBytes -> a
fromRawBytes (ReturnValue -> TypeInfo
rvTypeInfo ReturnValue
r1) (ReturnValue -> RawBytes
rvRawBytes ReturnValue
r1)
  fromReturnValues [ReturnValue]
_ = [Char] -> Only a
forall a. HasCallStack => [Char] -> a
error [Char]
"fromReturnValues: List length must be 1"

-- [MEMO] using Template Haskell
forM [2..30] $ \n -> do
  dec <- rpcOutputSetTupleQ n
--  runIO $ putStrLn $ pprint dec
  return dec
--instance (Data a1, Data a2) => RpcOutputSet (a1,a2) where
--  fromReturnValues [r1,r2] = (d1,d2)
--    where
--      !d1 = fromRawBytes (rvTypeInfo r1) (rvRawBytes r1)
--      !d2 = fromRawBytes (rvTypeInfo r2) (rvRawBytes r2)
--  fromReturnValues _ = error "fromReturnValues: List length must be 2"
--



-- (RpcOutputSet a, RpcResultSet b) => 
data RpcResponse a b = RpcResponse !Int !a !b
                     | RpcResponseError !Info
                   deriving (Int -> RpcResponse a b -> ShowS
[RpcResponse a b] -> ShowS
RpcResponse a b -> [Char]
(Int -> RpcResponse a b -> ShowS)
-> (RpcResponse a b -> [Char])
-> ([RpcResponse a b] -> ShowS)
-> Show (RpcResponse a b)
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
forall a b. (Show a, Show b) => Int -> RpcResponse a b -> ShowS
forall a b. (Show a, Show b) => [RpcResponse a b] -> ShowS
forall a b. (Show a, Show b) => RpcResponse a b -> [Char]
showList :: [RpcResponse a b] -> ShowS
$cshowList :: forall a b. (Show a, Show b) => [RpcResponse a b] -> ShowS
show :: RpcResponse a b -> [Char]
$cshow :: forall a b. (Show a, Show b) => RpcResponse a b -> [Char]
showsPrec :: Int -> RpcResponse a b -> ShowS
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> RpcResponse a b -> ShowS
Show)


rpcResponseParser :: (RpcOutputSet a, RpcResultSet b) => Bool -> Parser (RpcResponse a b)
rpcResponseParser :: Bool -> Parser (RpcResponse a b)
rpcResponseParser Bool
final = do
  let rrParser :: Parser (Either Info (RpcResponse a b))
rrParser = ExceptT Info Parser (RpcResponse a b)
-> Parser (Either Info (RpcResponse a b))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Info Parser (RpcResponse a b)
 -> Parser (Either Info (RpcResponse a b)))
-> ExceptT Info Parser (RpcResponse a b)
-> Parser (Either Info (RpcResponse a b))
forall a b. (a -> b) -> a -> b
$ do
        b
rrs <- Parser' b
forall a. RpcResultSet a => Parser' a
rpcResultSetParser
        [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
isTSReturnStatus -- [MEMO] necesarry ?
        TSReturnStatus Int32
ret <- (TokenStream -> Bool) -> Parser' TokenStream
trySatisfy TokenStream -> Bool
isTSReturnStatus
        [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
isTSReturnValue -- [MEMO] necesarry ?
        [TokenStream]
rvs <- (TokenStream -> Bool) -> Parser' [TokenStream]
trySatisfyMany TokenStream -> Bool
isTSReturnValue
        [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
isTSDoneProc -- [MEMO] necesarry ?
        TokenStream
_ <- if Bool
final
             then (TokenStream -> Bool) -> Parser' TokenStream
trySatisfy TokenStream -> Bool
isFinalTSDoneProc
             else (TokenStream -> Bool) -> Parser' TokenStream
trySatisfy TokenStream -> Bool
isTSDoneProc
        let rvs' :: [ReturnValue]
rvs' = (\(TSReturnValue ReturnValue
rv) -> ReturnValue
rv) (TokenStream -> ReturnValue) -> [TokenStream] -> [ReturnValue]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>  [TokenStream]
rvs
        RpcResponse a b -> ExceptT Info Parser (RpcResponse a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (RpcResponse a b -> ExceptT Info Parser (RpcResponse a b))
-> RpcResponse a b -> ExceptT Info Parser (RpcResponse a b)
forall a b. (a -> b) -> a -> b
$ Int -> a -> b -> RpcResponse a b
forall a b. Int -> a -> b -> RpcResponse a b
RpcResponse (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
ret) ([ReturnValue] -> a
forall a. RpcOutputSet a => [ReturnValue] -> a
fromReturnValues [ReturnValue]
rvs') b
rrs
  Either Info (RpcResponse a b)
err <- Parser (Either Info (RpcResponse a b))
rrParser
  case Either Info (RpcResponse a b)
err of
    Left Info
ei -> RpcResponse a b -> Parser (RpcResponse a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (RpcResponse a b -> Parser (RpcResponse a b))
-> RpcResponse a b -> Parser (RpcResponse a b)
forall a b. (a -> b) -> a -> b
$ Info -> RpcResponse a b
forall a b. Info -> RpcResponse a b
RpcResponseError Info
ei
    Right RpcResponse a b
rr -> RpcResponse a b -> Parser (RpcResponse a b)
forall (m :: * -> *) a. Monad m => a -> m a
return RpcResponse a b
rr

  where
    isTSReturnStatus :: TokenStream -> Bool
    isTSReturnStatus :: TokenStream -> Bool
isTSReturnStatus (TSReturnStatus{}) = Bool
True
    isTSReturnStatus TokenStream
_ = Bool
False

    isTSReturnValue :: TokenStream -> Bool
    isTSReturnValue :: TokenStream -> Bool
isTSReturnValue (TSReturnValue{}) = Bool
True
    isTSReturnValue TokenStream
_ = Bool
False





class RpcResponseSet a where
  rpcResponseSetParser :: Parser a

instance (RpcOutputSet a1, RpcResultSet b1) => RpcResponseSet (RpcResponse a1 b1) where
  rpcResponseSetParser :: Parser (RpcResponse a1 b1)
rpcResponseSetParser = Bool -> Parser (RpcResponse a1 b1)
forall a b.
(RpcOutputSet a, RpcResultSet b) =>
Bool -> Parser (RpcResponse a b)
rpcResponseParser Bool
True

-- [MEMO] using Template Haskell
forM [2..30] $ \n -> do
  dec <- rpcResponseSetTupleQ n
--  runIO $ putStrLn $ pprint dec
  return dec
--instance (RpcOutputSet a1, RpcResultSet b1, RpcOutputSet a2, RpcResultSet b2) => RpcResponseSet (RpcResponse a1 b1, RpcResponse a2 b2) where
--  rpcResponseSetParser = do
--    !r1 <- rpcResponseParser False
--    !r2 <- rpcResponseParser True
--    return (r1,r2)
--