{-# LANGUAGE CPP #-}
module Database.MSSQLServer.Query.TokenStreamParser ( Parser(..)
, parse
, item
, satisfy
, satisfyNotError
, Parser'(..)
, isTSError
, isTSDoneOrDoneProc
, isTSDone
, isTSDoneProc
, isFinalTSDoneOrDoneProc
, isFinalTSDone
, isFinalTSDoneProc
) where
import Control.Applicative(Applicative((<*>),pure),Alternative((<|>),empty),(<$>))
import Control.Monad(Monad(..),MonadPlus(..),ap)
import Data.Monoid ((<>),mconcat)
#if MIN_VERSION_base(4,9,0)
import Control.Monad.Fail(MonadFail(..))
#endif
import Database.Tds.Message
import Database.MSSQLServer.Query.Row
import Data.Bits ((.&.))
#if MIN_VERSION_mtl(2,2,1)
import Control.Monad.Except
#else
import Control.Monad.Error
import qualified Data.Text as T
#endif
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
satisfyNotError :: (TokenStream -> Bool) -> Parser TokenStream
satisfyNotError f = satisfy (\x -> f x && (not . isTSError) x)
#if MIN_VERSION_mtl(2,2,1)
type Parser' = ExceptT Info Parser
#else
type Parser' = ErrorT Info Parser
instance Error Info where
noMsg = Info 0 0 0 (T.pack "") (T.pack "") (T.pack "") 0
#endif
isTSError :: TokenStream -> Bool
isTSError (TSError{}) = True
isTSError _ = False
isTSDoneOrDoneProc :: TokenStream -> Bool
isTSDoneOrDoneProc (TSDone{}) = True
isTSDoneOrDoneProc (TSDoneProc{}) = True
isTSDoneOrDoneProc _ = False
isTSDone :: TokenStream -> Bool
isTSDone (TSDone{}) = True
isTSDone _ = False
isTSDoneProc :: TokenStream -> Bool
isTSDoneProc (TSDoneProc{}) = True
isTSDoneProc _ = False
isFinalTSDoneOrDoneProc :: TokenStream -> Bool
isFinalTSDoneOrDoneProc = (||) <$> isFinalTSDone <*> isFinalTSDoneProc
isFinalTSDone :: TokenStream -> Bool
isFinalTSDone = f
where
f :: TokenStream -> Bool
f (TSDone x) = isFinalDone x
f _ = False
isFinalTSDoneProc :: TokenStream -> Bool
isFinalTSDoneProc = f
where
f :: TokenStream -> Bool
f (TSDoneProc x) = isFinalDone x
f _ = False
isFinalDone :: Done -> Bool
isFinalDone (Done st _ _) = not $ st .&. 0x01 == 0x01