Parser.hs

{-# OPTIONS_GHC  -fno-warn-unused-do-bind #-}

-- ----------------------------------------------------------------------------

{- |
  Module     : Holumbus.Query.Language.Parser
  Copyright  : Copyright (C) 2007, 2008 Timo B. Huebel
  License    : MIT

  Maintainer : Timo B. Huebel (tbh@holumbus.org)
  Stability  : experimental
  Portability: portable
  Version    : 0.2

  The Holumbus query parser, based on the famous Parsec library.

  The parser implements a default syntax for the query grammar which exposes
  all possible query types and operators to the user.

-}

-- ----------------------------------------------------------------------------

module Holumbus.Query.Language.Parser
  (
  -- * Parsing
  parseQuery
  )
where

import Holumbus.Query.Language.Grammar
import Text.ParserCombinators.Parsec

-- ----------------------------------------------------------------------------

-- | Parse a query using the default syntax provided by the Holumbus framework.
parseQuery :: String -> Either String Query
parseQuery = result . (parse query "")
  where
  result (Left err) = Left (show err)
  result (Right q)  = Right q

-- | A query may always be surrounded by whitespace
query :: Parser Query
query = spaces >> andQuery

-- | Parse an and query.
andQuery :: Parser Query
andQuery = do t <- orQuery
              try (andOp' t) <|> return t
  where
  andOp' r = do andOp
                q <- andQuery
                return (BinQuery And r q)

-- | Parse an or query.
orQuery :: Parser Query
orQuery = do t <- notQuery
             do orOp
                q <- orQuery
                return (BinQuery Or t q)
                <|> return t

-- | Parse a negation.
notQuery :: Parser Query
notQuery = do notQuery' <|> contextQuery
  where
  notQuery' = do notOp
                 q <- contextQuery
                 return (Negation q)

-- | Parse a context query.
contextQuery :: Parser Query
contextQuery = try contextQuery' <|> parQuery
  where
  contextQuery' = do c <- contexts
                     spaces
                     char ':'
                     spaces
                     t <- parQuery
                     return (Specifier c t)

-- | Parse a query surrounded by parentheses.
parQuery :: Parser Query
parQuery = parQuery' <|> caseQuery
  where
  parQuery' = do char '('
                 spaces
                 q <- andQuery
                 spaces
                 char ')'
                 return q

-- | Parse a case-sensitive query.
caseQuery :: Parser Query
caseQuery = caseQuery' <|> fuzzyQuery
  where
  caseQuery' = do char '!'
                  spaces
                  (phraseQuery CasePhrase <|> wordQuery CaseWord)

-- | Parse a fuzzy query.
fuzzyQuery :: Parser Query
fuzzyQuery = fuzzyQuery' <|> phraseQuery Phrase <|> wordQuery Word
  where
  fuzzyQuery' = do char '~'
                   spaces
                   wordQuery FuzzyWord

-- | Parse a word query.
wordQuery :: (String -> Query) -> Parser Query
wordQuery c = do w <- word
                 return (c w)

-- | Parse a phrase query.
phraseQuery :: (String -> Query) -> Parser Query
phraseQuery c = do p <- phrase
                   return (c p)

-- | Parse an and operator.
andOp :: Parser ()
andOp = (try andOp') <|> spaces1
  where
  andOp' = do spaces
              string "AND"
              spaces1
              return ()

-- | Parse an or operator.
orOp :: Parser ()
orOp = try orOp'
  where
  orOp' = do spaces
             string "OR"
             spaces1
             return ()

-- | Parse a not operator.
notOp :: Parser ()
notOp = try notOp'
  where
  notOp' = do spaces
              string "NOT"
              spaces1
              return ()

-- | Parse a word.
word :: Parser String
word = many1 wordChar

-- | Parse a phrase.
phrase :: Parser String
phrase = do char '"'
            p <- many1 phraseChar
            char '"'
            return p

-- | Parse a character of a word.
wordChar :: Parser Char
wordChar = noneOf "\")( "

-- | Parse a character of a phrases.
phraseChar :: Parser Char
phraseChar = noneOf "\""

-- | Parse a list of contexts.
contexts :: Parser [String]
contexts = context `sepBy1` (char ',')

-- | Parse a context.
context :: Parser String
context = do spaces
             c <- (many1 alphaNum)
             spaces
             return c

-- | Parse at least on white space character.
spaces1 :: Parser ()
spaces1 = skipMany1 space

-- ------------------------------------------------------------