{-# LANGUAGE FlexibleContexts #-}
module Data.BoolExpr.Parser
  (-- * Parsing function
  parseBoolExpr
   -- * Language definition and components
  ,languageDef
  ,lexer
  ,identifier
  ,whiteSpace
  ,symbol
  )
where

import Control.Monad
import Data.BoolExpr
import Text.ParserCombinators.Parsec
import qualified Text.ParserCombinators.Parsec.Token as P

{- | Parse a search query as a boolean tree using the following grammar.
     Note that this parser is parameterized over the parser of query simple
     terms (const).

@
  bt ::= bt AND bt
        | bt bt -- same as AND
        | bt OR bt
        | - bt
        | NOT bt
        | ( bt )
        | const
   const ::= \<given as argument\>
@
-}
parseBoolExpr :: CharParser st a -> CharParser st (BoolExpr a)
parseBoolExpr :: forall st a. CharParser st a -> CharParser st (BoolExpr a)
parseBoolExpr CharParser st a
parseConst = ParsecT [Char] st Identity (BoolExpr a)
disj
   where disj :: ParsecT [Char] st Identity (BoolExpr a)
disj   = ParsecT [Char] st Identity (BoolExpr a)
conj   forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (a -> a -> a) -> ParsecT s u m a
`chainl1` forall {st} {a}.
ParsecT [Char] st Identity (BoolExpr a -> BoolExpr a -> BoolExpr a)
orOp
         conj :: ParsecT [Char] st Identity (BoolExpr a)
conj   = ParsecT [Char] st Identity (BoolExpr a)
factor forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (a -> a -> a) -> ParsecT s u m a
`chainl1` forall {st} {a}.
ParsecT [Char] st Identity (BoolExpr a -> BoolExpr a -> BoolExpr a)
andOp
         factor :: ParsecT [Char] st Identity (BoolExpr a)
factor =     (  (forall st. [Char] -> CharParser st [Char]
symbol [Char]
"-"   forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. BoolExpr a -> BoolExpr a
BNot)
                     forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (forall st. [Char] -> CharParser st [Char]
symbol [Char]
"NOT" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. BoolExpr a -> BoolExpr a
BNot)
                     forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. a -> a
id                  )
                      ) 
                      forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` 
                         (  forall st a. CharParser st a -> CharParser st a
parens ParsecT [Char] st Identity (BoolExpr a)
disj 
                        forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall a. Signed a -> BoolExpr a
BConst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (forall a. a -> Signed a
Positive forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` CharParser st a
parseConst)
                         )

         andOp :: ParsecT [Char] u Identity (BoolExpr a -> BoolExpr a -> BoolExpr a)
andOp = forall a. BoolExpr a -> BoolExpr a -> BoolExpr a
BAnd forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option [Char]
"" (forall st. [Char] -> CharParser st [Char]
symbol [Char]
"AND")
         orOp :: ParsecT [Char] st Identity (BoolExpr a -> BoolExpr a -> BoolExpr a)
orOp  = forall a. BoolExpr a -> BoolExpr a -> BoolExpr a
BOr forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall st. [Char] -> CharParser st [Char]
symbol [Char]
"OR"

-- | Underlying lexer of 'languageDef'
lexer :: P.TokenParser st
lexer :: forall st. TokenParser st
lexer = forall s (m :: * -> *) u.
Stream s m Char =>
GenLanguageDef s u m -> GenTokenParser s u m
P.makeTokenParser forall st. LanguageDef st
languageDef

-- | Shorthand for 'P.parens lexer'.
parens :: CharParser st a -> CharParser st a
parens :: forall st a. CharParser st a -> CharParser st a
parens = forall s u (m :: * -> *).
GenTokenParser s u m
-> forall a. ParsecT s u m a -> ParsecT s u m a
P.parens forall st. TokenParser st
lexer

-- | Shorthand for 'P.symbol' 'lexer'.
symbol :: String -> CharParser st String
symbol :: forall st. [Char] -> CharParser st [Char]
symbol = forall s u (m :: * -> *).
GenTokenParser s u m -> [Char] -> ParsecT s u m [Char]
P.symbol forall st. TokenParser st
lexer

-- | Shorthand for 'P.whiteSpace' 'lexer'.
whiteSpace :: CharParser st ()
whiteSpace :: forall st. CharParser st ()
whiteSpace = forall s u (m :: * -> *). GenTokenParser s u m -> ParsecT s u m ()
P.whiteSpace forall st. TokenParser st
lexer

-- | Shorthand for 'P.identifier' 'lexer'.
identifier :: CharParser st String
identifier :: forall st. CharParser st [Char]
identifier = do
    [Char]
str <- forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m [Char]
P.identifier forall st. TokenParser st
lexer
    forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
str

wordLetter :: CharParser st Char
wordLetter :: forall st. CharParser st Char
wordLetter = forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char]
"_:;`,~@.!#$%^&*=+?|\\{}[]<>"

-- | Basic language definition for search queries.
-- Reserved names are @\"AND\"@ @\"OR\"@ and @\"-\"@.
-- Identifiers accepts almost every ASCII sequences without blanks nor @\'-\'@.
languageDef :: P.LanguageDef st
languageDef :: forall st. LanguageDef st
languageDef = P.LanguageDef
               { commentStart :: [Char]
P.commentStart   = [Char]
""
               , commentEnd :: [Char]
P.commentEnd     = [Char]
""
               , commentLine :: [Char]
P.commentLine    = [Char]
""
               , nestedComments :: Bool
P.nestedComments = Bool
True
               , identStart :: ParsecT [Char] st Identity Char
P.identStart     = forall st. CharParser st Char
wordLetter
               , identLetter :: ParsecT [Char] st Identity Char
P.identLetter    = forall st. CharParser st Char
wordLetter forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'-'
               , opStart :: ParsecT [Char] st Identity Char
P.opStart        = forall (m :: * -> *) a. MonadPlus m => m a
mzero
               , opLetter :: ParsecT [Char] st Identity Char
P.opLetter       = forall (m :: * -> *) a. MonadPlus m => m a
mzero
               , reservedOpNames :: [[Char]]
P.reservedOpNames= []
               , reservedNames :: [[Char]]
P.reservedNames  = [[Char]
"AND", [Char]
"OR", [Char]
"-"]
               , caseSensitive :: Bool
P.caseSensitive  = Bool
True
               }