{-# 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 = do
_ <- many $ satisfy $ not . isTSError
ts <- satisfy isTSError
_ <- many $ satisfy $ not . isTSDoneOrDoneProc
_ <- satisfy isFinalTSDoneOrDoneProc
return ts
where
isTSError :: TokenStream -> Bool
isTSError (TSError{}) = True
isTSError _ = False
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 ()
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
return $ ReturnStatus $ fromIntegral rets
where
isTSReturnStatus :: TokenStream -> Bool
isTSReturnStatus (TSReturnStatus{}) = True
isTSReturnStatus _ = False
returnStatusDone :: Parser' ReturnStatus
returnStatusDone = do
rets <- returnStatus
_ <- trySatisfyMany $ not . isTSDoneProc
_ <- trySatisfy isTSDoneProc
return rets
returnStatusFinalDone :: Parser' ReturnStatus
returnStatusFinalDone = do
rets <- returnStatus
_ <- trySatisfyMany $ not . isFinalTSDoneProc
_ <- trySatisfy isFinalTSDoneProc
return rets
returnStatusFinalDone' :: Parser' ReturnStatus
returnStatusFinalDone' = do
rets <- returnStatus
_ <- trySatisfyMany $ not . isTSDoneProc
_ <- 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
tsRows <- trySatisfyMany isTSRow
return $
let
(TSColMetaData (maybeCmd)) = tsCmd
mcds = case (\(ColMetaData x) -> x) <$> maybeCmd of
Nothing -> error "listOfRow: ColMetaData is necessary"
Just mcds' -> mcds'
rows = (\(TSRow row) -> getRawBytes <$> row) <$> tsRows
in fromListOfRawBytes mcds <$> rows
where
isTSColMetaData :: TokenStream -> Bool
isTSColMetaData (TSColMetaData{}) = True
isTSColMetaData _ = False
isTSRow :: TokenStream -> Bool
isTSRow (TSRow{}) = True
isTSRow _ = False
getRawBytes :: RowColumnData -> RawBytes
getRawBytes (RCDOrdinal dt) = dt
getRawBytes (RCDLarge _ _ dt) = dt
listOfRowDone :: Row a => Parser' ([a])
listOfRowDone = do
rs <- listOfRow
_ <- trySatisfyMany $ not . isTSDone
_ <- trySatisfy $ isTSDone
return rs
listOfRowFinalDone :: Row a => Parser' ([a])
listOfRowFinalDone = do
rs <- listOfRow
_ <- trySatisfyMany $ not . isFinalTSDone
_ <- trySatisfy $ isFinalTSDone
return rs
listOfRowFinalDone' :: Row a => Parser' ([a])
listOfRowFinalDone' = do
rs <- listOfRow
_ <- trySatisfyMany $ not . isTSDone
_ <- trySatisfy $ isFinalTSDone
return rs
class ResultSet a where
resultSetParser :: Parser' a
instance ResultSet () where
resultSetParser = noResultFinalDone
instance ResultSet RowCount where
resultSetParser = rowCountFinalDone
instance ResultSet ReturnStatus where
resultSetParser = returnStatusFinalDone
instance (Row a) => ResultSet [a] where
resultSetParser = listOfRowFinalDone
forM [2..30] $ \n -> do
dec <- resultSetTupleQ n
return dec
class Result a where
resultParser :: Bool -> Parser' a
instance Result () where
resultParser True = noResultFinalDone'
resultParser _ = noResultDone
instance Result RowCount where
resultParser True = rowCountFinalDone'
resultParser _ = rowCountDone
instance Result ReturnStatus where
resultParser True = returnStatusFinalDone'
resultParser _ = returnStatusDone
instance Row a => Result [a] where
resultParser True = listOfRowFinalDone'
resultParser _ = listOfRowDone