{-# 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]
_  <- forall (f :: * -> *) a. Alternative f => f a -> f [a]
many forall a b. (a -> b) -> a -> b
$ (TokenStream -> Bool) -> Parser TokenStream
satisfy forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. TokenStream -> Bool
isTSError
  TokenStream
ts <- (TokenStream -> Bool) -> Parser TokenStream
satisfy TokenStream -> Bool
isTSError
  [TokenStream]
_  <- forall (f :: * -> *) a. Alternative f => f a -> f [a]
many forall a b. (a -> b) -> a -> b
$ (TokenStream -> Bool) -> Parser TokenStream
satisfy forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. TokenStream -> Bool
isFinalTSDoneProc
  TokenStream
_  <- (TokenStream -> Bool) -> Parser TokenStream
satisfy TokenStream -> Bool
isFinalTSDoneProc
  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 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ ((TokenStream -> Bool) -> Parser TokenStream
satisfyNotError TokenStream -> Bool
f) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser TokenStream
errorDone
  case TokenStream
ts of
    TSError Info
ei -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Info
ei
    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 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ (forall (f :: * -> *) a. Alternative f => f a -> f [a]
many forall a b. (a -> b) -> a -> b
$ (TokenStream -> Bool) -> Parser TokenStream
satisfyNotError TokenStream -> Bool
f) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((\TokenStream
x->[TokenStream
x]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser TokenStream
errorDone)
  case [TokenStream]
tss of
    (TSError Info
ei):[TokenStream]
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Info
ei
    [TokenStream]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return [TokenStream]
tss



listOfRow :: Row a => Parser' ([a])
listOfRow :: forall a. Row a => Parser' [a]
listOfRow = do
  [TokenStream]
_ <- (TokenStream -> Bool) -> Parser' [TokenStream]
trySatisfyMany forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not 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 forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not 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  forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. TokenStream -> Bool
isTSDoneInProc -- [MEMO] necesarry ?
  TokenStream
_ <- (TokenStream -> Bool) -> Parser' TokenStream
trySatisfy TokenStream -> Bool
isTSDoneInProc
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
    let
      (TSColMetaData (Maybe ColMetaData
maybeCmd)) = TokenStream
tsCmd
      mcds :: [MetaColumnData]
mcds = case (\(ColMetaData [MetaColumnData]
x) -> [MetaColumnData]
x) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ColMetaData
maybeCmd of
               Maybe [MetaColumnData]
Nothing -> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RowColumnData]
row) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TokenStream]
tsRows
    in forall a. Row a => [MetaColumnData] -> [RawBytes] -> a
fromListOfRawBytes [MetaColumnData]
mcds 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 = forall (m :: * -> *) a. Monad m => a -> m a
return ()


instance (Row a) => RpcResultSet [a] where
  rpcResultSetParser :: Parser' [a]
rpcResultSetParser = 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 = 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]
_ = 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] = forall a. a -> Only a
Only a
d1
    where
      !d1 :: a
d1 = forall a. Data a => TypeInfo -> RawBytes -> a
fromRawBytes (ReturnValue -> TypeInfo
rvTypeInfo ReturnValue
r1) (ReturnValue -> RawBytes
rvRawBytes ReturnValue
r1)
  fromReturnValues [ReturnValue]
_ = 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
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 :: forall a b.
(RpcOutputSet a, RpcResultSet b) =>
Bool -> Parser (RpcResponse a b)
rpcResponseParser Bool
final = do
  let rrParser :: Parser (Either Info (RpcResponse a b))
rrParser = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
        b
rrs <- forall a. RpcResultSet a => Parser' a
rpcResultSetParser
        [TokenStream]
_ <- (TokenStream -> Bool) -> Parser' [TokenStream]
trySatisfyMany forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not 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 forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not 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 forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not 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) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>  [TokenStream]
rvs
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. Int -> a -> b -> RpcResponse a b
RpcResponse (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
ret) (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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. Info -> RpcResponse a b
RpcResponseError Info
ei
    Right RpcResponse a b
rr -> 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 = 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)
--