{-# LANGUAGE CPP #-}
module Database.MSSQLServer.Query.TokenStreamParser ( Parser(..)
, parse
, item
, satisfy
, many
, many1
, oneOf
, noneOf
, noResult
, listOfRow
, rowCount
) where
import Control.Applicative((<$>))
import Control.Applicative(Applicative((<*>),pure),Alternative((<|>),empty))
import Control.Monad(Monad(..),MonadPlus(..),ap)
#if MIN_VERSION_base(4,9,0)
import Control.Monad.Fail(MonadFail(..))
#endif
import Data.Monoid (mconcat,(<>),All(..),Any(..))
import Database.Tds.Message
import Database.MSSQLServer.Query.Row
data Parser a = Parser ([TokenStream] -> [(a,[TokenStream])])
parse :: Parser a -> [TokenStream] -> [(a,[TokenStream])]
parse (Parser p) = p
instance Functor Parser where
fmap f p = Parser $ \xs -> [(f x,xs') | (x,xs') <- parse p xs]
instance Applicative Parser where
pure = return
(<*>) = ap
instance Alternative Parser where
empty = mzero
(<|>) = mplus
instance Monad Parser where
return x = Parser $ \xs -> [(x,xs)]
p >>= f = Parser $ \ts -> mconcat [parse (f t) ts' | (t,ts') <- parse p ts]
instance MonadPlus Parser where
mzero = Parser $ \_ -> []
mplus p q = Parser $ \xs -> parse p xs <> parse q xs
#if MIN_VERSION_base(4,9,0)
instance MonadFail Parser where
fail _ = mzero
#endif
item :: Parser TokenStream
item = Parser $ \xs -> case xs of
[] -> []
(x:xs') -> [(x,xs')]
satisfy :: (TokenStream -> Bool) -> Parser TokenStream
satisfy f = do x <- item
if f x
then return x
else empty
many :: Parser a -> Parser [a]
many p = many1 p <|> return []
many1 :: Parser a -> Parser [a]
many1 p = do a <- p
as <- many p
return $ a:as
oneOf :: [TokenStream -> Bool] -> Parser TokenStream
oneOf xs = satisfy $ \x -> getAny $ mconcat $ (\f -> Any $ f x) <$> xs
noneOf :: [TokenStream -> Bool] -> Parser TokenStream
noneOf xs = satisfy $ \x -> getAll $ mconcat $ (\f -> All $ not $ f x) <$> xs
noResult :: Parser ()
noResult = do
_ <- many $ satisfy $ not . isTSDone
_ <- satisfy isTSDone
return ()
where
isTSDone :: TokenStream -> Bool
isTSDone (TSDone{}) = True
isTSDone (TSDoneInProc{}) = True
isTSDone _ = False
listOfRow :: Row a => Parser ([a])
listOfRow = do
_ <- many $ satisfy $ not . isTSColMetaData
tsCmd <- satisfy isTSColMetaData
_ <- many $ satisfy $ not . isTSRow
tsRows <- many $ satisfy isTSRow
_ <- many $ satisfy $ not . isTSDone
_ <- satisfy isTSDone
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
isTSDone :: TokenStream -> Bool
isTSDone (TSDone{}) = True
isTSDone (TSDoneInProc{}) = True
isTSDone _ = False
getRawBytes :: RowColumnData -> RawBytes
getRawBytes (RCDOrdinal dt) = dt
getRawBytes (RCDLarge _ _ dt) = dt
rowCount :: Parser Int
rowCount = do
_ <- many $ satisfy $ not . isTSDone
tsDone <- satisfy isTSDone
return $
let
Done _ _ rc = getDone tsDone
in fromIntegral rc
where
isTSDone :: TokenStream -> Bool
isTSDone (TSDone{}) = True
isTSDone (TSDoneInProc{}) = True
isTSDone _ = False
getDone :: TokenStream -> Done
getDone (TSDone x) = x
getDone (TSDoneInProc x) = x
getDone _ = error "rowCount: TSDone and TSDoneInProc are only possible here"