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

{- |
  Module     : Hayoo.Parser
  Copyright  : Copyright (C) 2008 Timo B. Huebel
  License    : MIT

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

  The parser for the Hayoo! web search.
 
-}

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

module Hayoo.Search.Parser where

-- import qualified Data.Map as M
-- import Data.Char

import Hayoo.Signature

-- import Holumbus.Utility
import Holumbus.Query.Language.Grammar

import Text.ParserCombinators.Parsec

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

{- Uwe: done 

-- TODO TH This normalize and strip have to be shared by indexer and search!

-- | Normalizes a Haskell signature, e.g. @String -> Int -> Int@ will be transformed to 
-- @a->b->b@. All whitespace will be removed from the resulting string.
normalizeSignature :: String -> String
normalizeSignature = join "->" . (replaceTypes M.empty ['a'..'z']) . split "->" . filter (not . isSpace)
  where
  replaceTypes _ _ [] = []
  replaceTypes v t (x:xs) = let (nv, ut, rx) = replace' in rx:(replaceTypes nv ut xs)
    where
    replace' = let ut = [head t] in maybe (M.insert r ut v, tail t, ut) (\n -> (v, t, n)) (M.lookup r v)
      where r = stripWith (\c -> (c == '(') || (c == ')')) x

-- | Strip unneeded whitespace from a signature, e.g. @String -> Map k a -> Int@ will be transformed
-- to @String->Map k a->Int@.
stripSignature :: String -> String
stripSignature = sep "->" . lsep "(" . rsep ")" . sep "." . sep "=>"
  where
  sep s = join s . map strip . split s
  lsep s = join s . map stripl . split s
  rsep s = join s . map stripr . split s
-}

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

-- | Parse a query using the special Hayoo! syntax.
parseQuery :: String -> Either String Query
parseQuery s
    | isSignature s     = Right sigQuery
    | otherwise         = result . (parse query "") $ s
  where
  sigQuery              = BinQuery Or
                          (Specifier ["signature"]  (Word $ stripSignature     s))
                          (Specifier ["normalized"] (Word $ normalizeSignature s))

  result (Left _e)      = Right (FuzzyWord s)
  result (Right q)      = Right q

-- | A query may always be surrounded by whitespace
query :: Parser Query
query = spaces >> andQuery
-- query = spaces >> ((try sigQuery) <|> (andQuery))

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

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

-- | Parse a negation.
notQuery :: Parser Query
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' <|> phraseQuery <|> wordQuery
  where
  parQuery' = do _ <- char '('
                 spaces
                 q <- andQuery
                 spaces
                 _ <- char ')'
                 return q

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

-- | Parse a word query.
wordQuery :: Parser Query
wordQuery = do w <- word
               return (FuzzyWord w)
{-
-- | Parse a signature.
sigQuery :: Parser Query
sigQuery = do
           r <- contains "->"
           s <- return (stripSignature r)
           n <- return (normalizeSignature r)
           return $ BinQuery Or (Specifier ["signature"] (Word s)) (Specifier ["normalized"] (Word n))
-}
contains :: String -> Parser String
contains s = do
             pr <- many1 (noneOf s)
             _ <- string s
             po <- many1 anyChar
             return (pr ++ s ++ po)

-- | 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