module Hoogle.Query.Parser(parseQuery) where

import Control.Applicative ((*>))
import General.Base
import Hoogle.Query.Type
import Hoogle.Type.All as Hoogle
import Text.ParserCombinators.Parsec hiding (ParseError)
import qualified Text.ParserCombinators.Parsec as Parsec


parseQuery :: String -> Either ParseError Query
parseQuery x = case bracketer x of
    Left err -> Left err
    Right _ -> case parse parsecQuery "" x of
        Left err -> Left $ toParseError x err
        Right x -> Right x


toParseError :: String -> Parsec.ParseError -> Hoogle.ParseError
toParseError src x = parseErrorWith (sourceLine pos) (sourceColumn pos) (show x) src
    where pos = errorPos x


ascSymbols = "->!#$%&*+./<=?@\\^|~:"


optionBool :: Parser a -> Parser Bool
optionBool p = (p >> return True) <|> return False


---------------------------------------------------------------------
-- QUERY PARSEC

parsecQuery :: Parser Query
parsecQuery = do spaces ; try (end names) <|> (end types)
    where
        end f = do x <- f; eof; return x
    
        names = do a <- many (flag <|> name)
                   b <- option mempty (string "::" >> spaces >> types)
                   let res@Query{names=names} = mappend (mconcat a) b
                       (op,nop) = partition ((`elem` ascSymbols) . head) names
                   if op /= [] && nop /= []
                       then fail "Combination of operators and names"
                       else return res

        handleMatch xs = case xs of
            [x] -> mempty{names=[x]}
            xs -> mempty{names=[last xs]
                        ,scope=[Scope True Module $ intercalate "." $ init xs]}

        name = (do xs <- char '*' *> keyword `sepBy1` (char '.') ; spaces
                   return $ (handleMatch xs) { invertResults = True }
               <|>
               do x <- operator ; spaces ; return mempty{names=[x]})
               <|>
               (do xs <- keyword `sepBy1` (char '.') ; spaces
                   return $ handleMatch xs
               )
        
        operator = between (char '(') (char ')') op <|> op

        op = try $ do
            res <- many1 $ satisfy (`elem` ascSymbols)
            if res == "::" then fail ":: is not an operator name" else return res
        
        types = do a <- flags
                   b <- parsecTypeSig
                   c <- flags
                   return $ mconcat [a,mempty{typeSig=Just b},c]

        flag = try $ do x <- parseFlagScope; spaces; return x
        flags = fmap mconcat $ many flag


-- deal with the parsing of:
--     -package
--     +Module.Name
parseFlagScope :: Parser Query
parseFlagScope = do
    pm <- fmap (== '+') $ oneOf "+-"
    modu <- keyword `sepBy1` (char '.')
    let typ = case modu of [x] | isLower (head x) -> Package; _ -> Module
    return mempty{scope=[Scope pm typ $ intercalate "." modu]}


keyword = do
    x <- letter
    xs <- many $ satisfy $ \x -> isAlphaNum x || x `elem` "_'#-"
    return $ x:xs


---------------------------------------------------------------------
-- TYPESIG PARSEC

parsecTypeSig :: Parser TypeSig
parsecTypeSig = do whites
                   c <- context
                   t <- typ0
                   return $ normaliseTypeSig $ TypeSig c t
    where
        -- all the parser must swallow up all trailing white space after them
        context = try acontext <|> return []
        
        acontext = do x <- conitems <|> fmap (:[]) conitem
                      white $ string "=>"
                      return x
        
        conitems = between (wchar '(') (wchar ')') $ conitem `sepBy1` wchar ','
        conitem = typ1
        
    
        typ0 = function
        typ1 = application
        typ2 = forAll <|> tuple <|> list <|> atom <|> bang

        bang = wchar '!' >> typ2
        
        forAll = do try (white $ string "forall")
                    many atom
                    wchar '.'
                    TypeSig con typ <- parsecTypeSig
                    return typ


        -- match (a,b) and (,)
        -- also pick up ( -> )
        tuple = do char '('
                   hash <- optionBool $ char '#'
                   let close = white $ string $ ['#'|hash] ++ ")"
                   whites 
                   (do wchar ','
                       xs <- many $ wchar ','
                       close
                       return $ tLit hash (length xs + 1)
                    ) <|>
                    (do sym <- white keysymbol
                        close
                        return $ TLit sym
                    ) <|>
                    (do xs <- typ0 `sepBy` wchar ','
                        close
                        return $ case xs of
                            [] -> TLit "()"
                            [x] -> x
                            xs -> TApp (tLit hash $ length xs - 1) xs
                    )
            where
                tLit hash n = TLit $ "(" ++ h ++ replicate n ',' ++ h ++ ")"
                    where h = ['#'|hash]
            
            
        atom = do x <- satisfy (\x -> isAlpha x || x == '_')
                  xs <- many $ satisfy (\x -> isAlphaNum x || x `elem` "_'#")
                  whites
                  return $ (if isLower x || x == '_' then TVar else TLit) (x:xs)

        -- may be [a], or [] (then application takes the a after it)
        list = do char '['
                  colon <- optionBool $ char ':'
                  spaces
                  let close = white $ string $ [':'|colon] ++ "]"
                      lit = TLit $ if colon then "[::]" else "[]"
                  (close >> return lit) <|> (do
                      x <- typ0
                      close
                      return $ TApp lit [x])

        application = do (x:xs) <- many1 (white typ2)
                         return $ TApp x xs

        function = do lhs <- typ1
                      (do op <- white keysymbol; rhs <- function; return $ TApp (TLit op) [lhs,rhs])
                          <|> return lhs

        wchar c = white $ char c
        white x = do y <- x ; whites ; return y

        whites = many whiteChar
        whiteChar = oneOf " \v\f\t\r"

        keysymbol = try $ do
            x <- many1 $ satisfy (\x -> isSymbol x || x `elem` ascSymbols)
            if x `elem` reservedSym then fail "Bad symbol" else return x
        reservedSym = ["::","=>",".","=","#",":","-","+","/","--"]


--------------------------------------------------------------------
-- BRACKETER

openBrackets = "(["
shutBrackets = ")]"


data Bracket = Bracket Char [Bracket] -- Char is one of '(' or '['
             | NoBracket Char
               deriving Show

bracketer :: String -> Either ParseError [Bracket]
bracketer xs = case readBracket (1,xs) of
    Left (msg,from,to) -> f msg from to
    Right (res,(i,_:_)) -> f "Unexpected closing bracket" i (1+length xs)
    Right (res,_) -> Right res
    where
        f msg from to = Left $ ParseError 1 from msg $ formatTags xs [((from-1,to-1),TagEmph)]


type StrPos = (Int,String)

-- Given a list of pos/chars return either a failure (msg,start,end) or some bracket and the remaining chars
readBracket :: StrPos -> Either (String,Int,Int) ([Bracket], StrPos)
readBracket (i,"") = Right ([],(i,""))
readBracket (i, x:xs)
    | x `elem` shutBrackets = Right ([], (i,x:xs))
    | x `elem` openBrackets = case readBracket (i+1,xs) of
        Left e -> Left e
        Right (_, (j,[])) -> Left ("Closing bracket expected", i, j)
        Right (res, (j,y:ys))
            | elemIndex x openBrackets /= elemIndex y shutBrackets -> Left ("Bracket mismatch", i, j+1)
            | otherwise -> case readBracket (j+1,ys) of
                Left e -> Left e
                Right (a,b) -> Right (Bracket x res:a, b)
    | otherwise = case readBracket (i+1,xs) of
        Left e -> Left e
        Right (a,b) -> Right (NoBracket x:a, b)