{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}


module Database.MSSQLServer.Query.ResultSet ( ResultSet (..)
                                            , Result (..)
                                            ) 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
#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
isTSDoneOrDoneProc -- [MEMO] skip Info
  TokenStream
_  <- (TokenStream -> Bool) -> Parser TokenStream
satisfy TokenStream -> Bool
isFinalTSDoneOrDoneProc
  forall (m :: * -> *) a. Monad m => a -> m a
return TokenStream
ts
  where
    isTSError :: TokenStream -> Bool
    isTSError :: TokenStream -> Bool
isTSError (TSError{}) = Bool
True
    isTSError TokenStream
_ = Bool
False


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



noResultDone :: Parser' ()
noResultDone :: Parser' ()
noResultDone = 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
isTSDoneOrDoneProc
  TokenStream
_ <- (TokenStream -> Bool) -> Parser' TokenStream
trySatisfy TokenStream -> Bool
isTSDoneOrDoneProc
  forall (m :: * -> *) a. Monad m => a -> m a
return ()

noResultFinalDone :: Parser' ()
noResultFinalDone :: Parser' ()
noResultFinalDone = 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
isFinalTSDoneOrDoneProc
  TokenStream
_ <- (TokenStream -> Bool) -> Parser' TokenStream
trySatisfy TokenStream -> Bool
isFinalTSDoneOrDoneProc
  forall (m :: * -> *) a. Monad m => a -> m a
return ()

noResultFinalDone' :: Parser' ()
noResultFinalDone' :: Parser' ()
noResultFinalDone' = 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
isTSDoneOrDoneProc
  TokenStream
_ <- (TokenStream -> Bool) -> Parser' TokenStream
trySatisfy TokenStream -> Bool
isFinalTSDoneOrDoneProc
  forall (m :: * -> *) a. Monad m => a -> m a
return ()



returnStatus :: Parser' ReturnStatus
returnStatus :: Parser' ReturnStatus
returnStatus = 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
isTSReturnStatus
  TSReturnStatus Int32
rets <- (TokenStream -> Bool) -> Parser' TokenStream
trySatisfy TokenStream -> Bool
isTSReturnStatus
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> ReturnStatus
ReturnStatus forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
rets
  where
    isTSReturnStatus :: TokenStream -> Bool
    isTSReturnStatus :: TokenStream -> Bool
isTSReturnStatus (TSReturnStatus{}) = Bool
True
    isTSReturnStatus TokenStream
_ = Bool
False

returnStatusDone :: Parser' ReturnStatus
returnStatusDone :: Parser' ReturnStatus
returnStatusDone = do
  ReturnStatus
rets <- Parser' ReturnStatus
returnStatus
  [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] skip ReturnValue
  TokenStream
_ <- (TokenStream -> Bool) -> Parser' TokenStream
trySatisfy TokenStream -> Bool
isTSDoneProc
  forall (m :: * -> *) a. Monad m => a -> m a
return ReturnStatus
rets

returnStatusFinalDone :: Parser' ReturnStatus
returnStatusFinalDone :: Parser' ReturnStatus
returnStatusFinalDone = do
  ReturnStatus
rets <- Parser' ReturnStatus
returnStatus
  [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
isFinalTSDoneProc -- [MEMO] skip ReturnValue
  TokenStream
_ <- (TokenStream -> Bool) -> Parser' TokenStream
trySatisfy TokenStream -> Bool
isFinalTSDoneProc
  forall (m :: * -> *) a. Monad m => a -> m a
return ReturnStatus
rets

returnStatusFinalDone' :: Parser' ReturnStatus
returnStatusFinalDone' :: Parser' ReturnStatus
returnStatusFinalDone' = do
  ReturnStatus
rets <- Parser' ReturnStatus
returnStatus
  [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] skip ReturnValue
  TokenStream
_ <- (TokenStream -> Bool) -> Parser' TokenStream
trySatisfy TokenStream -> Bool
isFinalTSDoneProc
  forall (m :: * -> *) a. Monad m => a -> m a
return ReturnStatus
rets



rowCountDone :: Parser' RowCount
rowCountDone :: Parser' RowCount
rowCountDone = 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
isTSDone
  TSDone (Done DoneStatus
_ DoneStatus
_ Int32
rc) <- (TokenStream -> Bool) -> Parser' TokenStream
trySatisfy TokenStream -> Bool
isTSDone
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> RowCount
RowCount forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
rc

rowCountFinalDone :: Parser' RowCount
rowCountFinalDone :: Parser' RowCount
rowCountFinalDone = 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
isFinalTSDone
  TSDone (Done DoneStatus
_ DoneStatus
_ Int32
rc) <- (TokenStream -> Bool) -> Parser' TokenStream
trySatisfy TokenStream -> Bool
isFinalTSDone
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> RowCount
RowCount forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
rc

rowCountFinalDone' :: Parser' RowCount
rowCountFinalDone' :: Parser' RowCount
rowCountFinalDone' = 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
isTSDone
  TSDone (Done DoneStatus
_ DoneStatus
_ Int32
rc) <- (TokenStream -> Bool) -> Parser' TokenStream
trySatisfy TokenStream -> Bool
isFinalTSDone
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> RowCount
RowCount forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
rc



listOfRow :: Row a => Parser' ([a])
listOfRow :: forall a. Row a => Parser' [a]
listOfRow = do
  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
  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

    getRawBytes :: RowColumnData -> RawBytes
    getRawBytes :: RowColumnData -> RawBytes
getRawBytes (RCDOrdinal RawBytes
dt) = RawBytes
dt
    getRawBytes (RCDLarge Maybe TextPointer
_ Maybe TimeStamp
_ RawBytes
dt) = RawBytes
dt

listOfRowDone :: Row a => Parser' ([a])
listOfRowDone :: forall a. Row a => Parser' [a]
listOfRowDone = do
  [a]
rs <- forall a. Row a => Parser' [a]
listOfRow
  [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
isTSDone -- [MEMO] necesarry ?
  TokenStream
_ <- (TokenStream -> Bool) -> Parser' TokenStream
trySatisfy forall a b. (a -> b) -> a -> b
$ TokenStream -> Bool
isTSDone
  forall (m :: * -> *) a. Monad m => a -> m a
return [a]
rs

listOfRowFinalDone :: Row a => Parser' ([a])
listOfRowFinalDone :: forall a. Row a => Parser' [a]
listOfRowFinalDone = do
  [a]
rs <- forall a. Row a => Parser' [a]
listOfRow
  [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
isFinalTSDone -- [MEMO] necesarry ?
  TokenStream
_ <- (TokenStream -> Bool) -> Parser' TokenStream
trySatisfy forall a b. (a -> b) -> a -> b
$ TokenStream -> Bool
isFinalTSDone
  forall (m :: * -> *) a. Monad m => a -> m a
return [a]
rs

listOfRowFinalDone' :: Row a => Parser' ([a])
listOfRowFinalDone' :: forall a. Row a => Parser' [a]
listOfRowFinalDone' = do
  [a]
rs <- forall a. Row a => Parser' [a]
listOfRow
  [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
isTSDone -- [MEMO] necesarry ?
  TokenStream
_ <- (TokenStream -> Bool) -> Parser' TokenStream
trySatisfy forall a b. (a -> b) -> a -> b
$ TokenStream -> Bool
isFinalTSDone
  forall (m :: * -> *) a. Monad m => a -> m a
return [a]
rs



class ResultSet a where
  resultSetParser :: Parser' a


instance ResultSet () where
  resultSetParser :: Parser' ()
resultSetParser = Parser' ()
noResultFinalDone

instance ResultSet RowCount where
  resultSetParser :: Parser' RowCount
resultSetParser = Parser' RowCount
rowCountFinalDone

instance ResultSet ReturnStatus where
  resultSetParser :: Parser' ReturnStatus
resultSetParser = Parser' ReturnStatus
returnStatusFinalDone

instance (Row a) => ResultSet [a] where
  resultSetParser :: Parser' [a]
resultSetParser = forall a. Row a => Parser' [a]
listOfRowFinalDone



-- [MEMO] using Template Haskell
forM [2..30] $ \n -> do
  dec <- resultSetTupleQ n
--  runIO $ putStrLn $ pprint dec
  return dec
--instance (Result a1, Result a2) => ResultSet (a1, a2) where
--  resultSetParser = do
--    !r1 <- resultParser False :: (Result a1) => Parser' a1
--    !r2 <- resultParser True :: (Result a2) => Parser' a2
--    return  (r1,r2)
--


class Result a where
  resultParser :: Bool -> Parser' a -- [MEMO] 1st param: isFinal

instance Result () where
  resultParser :: Bool -> Parser' ()
resultParser Bool
True = Parser' ()
noResultFinalDone'
  resultParser Bool
_ = Parser' ()
noResultDone

instance Result RowCount where
  resultParser :: Bool -> Parser' RowCount
resultParser Bool
True = Parser' RowCount
rowCountFinalDone'
  resultParser Bool
_ = Parser' RowCount
rowCountDone

instance Result ReturnStatus where
  resultParser :: Bool -> Parser' ReturnStatus
resultParser Bool
True = Parser' ReturnStatus
returnStatusFinalDone'
  resultParser Bool
_ = Parser' ReturnStatus
returnStatusDone

instance Row a => Result [a] where
  resultParser :: Bool -> Parser' [a]
resultParser Bool
True = forall a. Row a => Parser' [a]
listOfRowFinalDone'
  resultParser Bool
_ = forall a. Row a => Parser' [a]
listOfRowDone