{-# 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 a -> [TokenStream] -> [(a, [TokenStream])]
parse (Parser [TokenStream] -> [(a, [TokenStream])]
p) = [TokenStream] -> [(a, [TokenStream])]
p


instance Functor Parser where
  fmap :: (a -> b) -> Parser a -> Parser b
fmap a -> b
f Parser a
p = ([TokenStream] -> [(b, [TokenStream])]) -> Parser b
forall a. ([TokenStream] -> [(a, [TokenStream])]) -> Parser a
Parser (([TokenStream] -> [(b, [TokenStream])]) -> Parser b)
-> ([TokenStream] -> [(b, [TokenStream])]) -> Parser b
forall a b. (a -> b) -> a -> b
$ \[TokenStream]
xs -> [(a -> b
f a
x,[TokenStream]
xs') | (a
x,[TokenStream]
xs') <- Parser a -> [TokenStream] -> [(a, [TokenStream])]
forall a. Parser a -> [TokenStream] -> [(a, [TokenStream])]
parse Parser a
p [TokenStream]
xs]

instance Applicative Parser where
  pure :: a -> Parser a
pure = a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return
  <*> :: Parser (a -> b) -> Parser a -> Parser b
(<*>) = Parser (a -> b) -> Parser a -> Parser b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Alternative Parser where
  empty :: Parser a
empty = Parser a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  <|> :: Parser a -> Parser a -> Parser a
(<|>) = Parser a -> Parser a -> Parser a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus

instance Monad Parser where
  return :: a -> Parser a
return a
x = ([TokenStream] -> [(a, [TokenStream])]) -> Parser a
forall a. ([TokenStream] -> [(a, [TokenStream])]) -> Parser a
Parser (([TokenStream] -> [(a, [TokenStream])]) -> Parser a)
-> ([TokenStream] -> [(a, [TokenStream])]) -> Parser a
forall a b. (a -> b) -> a -> b
$ \[TokenStream]
xs -> [(a
x,[TokenStream]
xs)]
  Parser a
p >>= :: Parser a -> (a -> Parser b) -> Parser b
>>= a -> Parser b
f  = ([TokenStream] -> [(b, [TokenStream])]) -> Parser b
forall a. ([TokenStream] -> [(a, [TokenStream])]) -> Parser a
Parser (([TokenStream] -> [(b, [TokenStream])]) -> Parser b)
-> ([TokenStream] -> [(b, [TokenStream])]) -> Parser b
forall a b. (a -> b) -> a -> b
$ \[TokenStream]
ts -> [[(b, [TokenStream])]] -> [(b, [TokenStream])]
forall a. Monoid a => [a] -> a
mconcat [Parser b -> [TokenStream] -> [(b, [TokenStream])]
forall a. Parser a -> [TokenStream] -> [(a, [TokenStream])]
parse (a -> Parser b
f a
t) [TokenStream]
ts' | (a
t,[TokenStream]
ts') <- Parser a -> [TokenStream] -> [(a, [TokenStream])]
forall a. Parser a -> [TokenStream] -> [(a, [TokenStream])]
parse Parser a
p [TokenStream]
ts]

instance MonadPlus Parser where
  mzero :: Parser a
mzero = ([TokenStream] -> [(a, [TokenStream])]) -> Parser a
forall a. ([TokenStream] -> [(a, [TokenStream])]) -> Parser a
Parser (([TokenStream] -> [(a, [TokenStream])]) -> Parser a)
-> ([TokenStream] -> [(a, [TokenStream])]) -> Parser a
forall a b. (a -> b) -> a -> b
$ \[TokenStream]
_ -> []
  mplus :: Parser a -> Parser a -> Parser a
mplus Parser a
p Parser a
q = ([TokenStream] -> [(a, [TokenStream])]) -> Parser a
forall a. ([TokenStream] -> [(a, [TokenStream])]) -> Parser a
Parser (([TokenStream] -> [(a, [TokenStream])]) -> Parser a)
-> ([TokenStream] -> [(a, [TokenStream])]) -> Parser a
forall a b. (a -> b) -> a -> b
$ \[TokenStream]
xs -> Parser a -> [TokenStream] -> [(a, [TokenStream])]
forall a. Parser a -> [TokenStream] -> [(a, [TokenStream])]
parse Parser a
p [TokenStream]
xs [(a, [TokenStream])]
-> [(a, [TokenStream])] -> [(a, [TokenStream])]
forall a. Semigroup a => a -> a -> a
<> Parser a -> [TokenStream] -> [(a, [TokenStream])]
forall a. Parser a -> [TokenStream] -> [(a, [TokenStream])]
parse Parser a
q [TokenStream]
xs

#if MIN_VERSION_base(4,9,0)
instance MonadFail Parser where
  fail :: String -> Parser a
fail String
_ = Parser a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
#endif


item :: Parser TokenStream
item :: Parser TokenStream
item = ([TokenStream] -> [(TokenStream, [TokenStream])])
-> Parser TokenStream
forall a. ([TokenStream] -> [(a, [TokenStream])]) -> Parser a
Parser (([TokenStream] -> [(TokenStream, [TokenStream])])
 -> Parser TokenStream)
-> ([TokenStream] -> [(TokenStream, [TokenStream])])
-> Parser TokenStream
forall a b. (a -> b) -> a -> b
$ \[TokenStream]
xs -> case [TokenStream]
xs of
                         [] -> []
                         (TokenStream
x:[TokenStream]
xs') -> [(TokenStream
x,[TokenStream]
xs')]

satisfy :: (TokenStream -> Bool) -> Parser TokenStream
satisfy :: (TokenStream -> Bool) -> Parser TokenStream
satisfy TokenStream -> Bool
f = do TokenStream
x <- Parser TokenStream
item
               if TokenStream -> Bool
f TokenStream
x
                 then TokenStream -> Parser TokenStream
forall (m :: * -> *) a. Monad m => a -> m a
return TokenStream
x
                 else Parser TokenStream
forall (f :: * -> *) a. Alternative f => f a
empty

satisfyNotError :: (TokenStream -> Bool) -> Parser TokenStream
satisfyNotError :: (TokenStream -> Bool) -> Parser TokenStream
satisfyNotError TokenStream -> Bool
f = (TokenStream -> Bool) -> Parser TokenStream
satisfy (\TokenStream
x -> TokenStream -> Bool
f TokenStream
x Bool -> Bool -> Bool
&& (Bool -> Bool
not (Bool -> Bool) -> (TokenStream -> Bool) -> TokenStream -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TokenStream -> Bool
isTSError) TokenStream
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 :: TokenStream -> Bool
isTSError (TSError{}) = Bool
True
isTSError TokenStream
_ = Bool
False

isTSDoneOrDoneProc :: TokenStream -> Bool
isTSDoneOrDoneProc :: TokenStream -> Bool
isTSDoneOrDoneProc (TSDone{}) = Bool
True
isTSDoneOrDoneProc (TSDoneProc{}) = Bool
True
isTSDoneOrDoneProc TokenStream
_ = Bool
False

isTSDone :: TokenStream -> Bool
isTSDone :: TokenStream -> Bool
isTSDone (TSDone{}) = Bool
True
isTSDone TokenStream
_ = Bool
False

isTSDoneProc :: TokenStream -> Bool
isTSDoneProc :: TokenStream -> Bool
isTSDoneProc (TSDoneProc{}) = Bool
True
isTSDoneProc TokenStream
_ = Bool
False


isFinalTSDoneOrDoneProc :: TokenStream -> Bool
isFinalTSDoneOrDoneProc :: TokenStream -> Bool
isFinalTSDoneOrDoneProc = Bool -> Bool -> Bool
(||) (Bool -> Bool -> Bool)
-> (TokenStream -> Bool) -> TokenStream -> Bool -> Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TokenStream -> Bool
isFinalTSDone (TokenStream -> Bool -> Bool)
-> (TokenStream -> Bool) -> TokenStream -> Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TokenStream -> Bool
isFinalTSDoneProc

isFinalTSDone :: TokenStream -> Bool
isFinalTSDone :: TokenStream -> Bool
isFinalTSDone = TokenStream -> Bool
f
  where
    f :: TokenStream -> Bool
    f :: TokenStream -> Bool
f (TSDone Done
x) = Done -> Bool
isFinalDone Done
x
    f TokenStream
_ = Bool
False

isFinalTSDoneProc :: TokenStream -> Bool
isFinalTSDoneProc :: TokenStream -> Bool
isFinalTSDoneProc = TokenStream -> Bool
f
  where
    f :: TokenStream -> Bool
    f :: TokenStream -> Bool
f (TSDoneProc Done
x) = Done -> Bool
isFinalDone Done
x
    f TokenStream
_ = Bool
False

isFinalDone :: Done -> Bool
isFinalDone :: Done -> Bool
isFinalDone (Done DoneStatus
st DoneStatus
_ DoneRowCount
_) = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ DoneStatus
st DoneStatus -> DoneStatus -> DoneStatus
forall a. Bits a => a -> a -> a
.&. DoneStatus
0x01 DoneStatus -> DoneStatus -> Bool
forall a. Eq a => a -> a -> Bool
== DoneStatus
0x01 -- [MEMO] 0x01 more bit