{-# LANGUAGE PatternGuards, ViewPatterns, RecordWildCards #-}

module Query(
    Query(..), isQueryName, isQueryType, isQueryScope,
    parseQuery, renderQuery,
    query_test
    ) where

import Data.List
import Language.Haskell.Exts
import Data.Char
import Data.List.Extra
import Data.Generics.Uniplate.Data
import General.Util
import Data.Maybe
import Control.Applicative
import Prelude

---------------------------------------------------------------------
-- DATA TYPE

data Query
    = QueryName {fromQueryName :: String}
    | QueryType {fromQueryType :: Type ()}
    | QueryScope {scopeInclude :: Bool, scopeCategory :: String, scopeValue :: String}
    | QueryNone String -- part of the query that is ignored
      deriving (Show,Eq)

isQueryName, isQueryType, isQueryScope :: Query -> Bool
isQueryName QueryName{} = True; isQueryName _ = False
isQueryType QueryType{} = True; isQueryType _ = False
isQueryScope QueryScope{} = True; isQueryScope _ = False

renderQuery :: [Query] -> String
renderQuery [] = "<i>No query</i>"
renderQuery xs = unwords $
    [escapeHTML x | QueryName x <- xs] ++
    [":: " ++ escapeHTML (pretty x) | QueryType x <- xs] ++
    [['-' | not scopeInclude] ++ escapeHTML scopeCategory ++ ":" ++ escapeHTML scopeValue | QueryScope{..} <- xs] ++
    ["<strike>" ++ escapeHTML x ++ "</strike>" | QueryNone x <- xs]


---------------------------------------------------------------------
-- PARSER

parseQuery :: String -> [Query]
parseQuery x = map QueryName nam ++ map QueryType (maybeToList typ) ++ scp
    where
        (scp,rest) = scope_ $ lexer x
        (nam,typ) = divide rest


openBrackets = ["(#","[:","(","["]
shutBrackets = ["#)",":]",")","]"]

isBracket x = x `elem` (openBrackets ++ shutBrackets)
isBracketPair x = x `elem` zipWith (++) openBrackets shutBrackets

isSym x = ((isSymbol x || isPunctuation x) && x `notElem` special) || x `elem` ascSymbol
    where special = "(),;[]`{}\"'"
          ascSymbol = "!#$%&*+./<=>?@\\^|-~"

isSyms xs | isBracket xs || isBracketPair xs = False
isSyms (x:xs) = isSym x
isSyms [] = False

-- | Split into small lexical chunks.
--
-- > "Data.Map.(!)" ==> ["Data",".","Map",".","(","!",")"]
lexer :: String -> [String]
lexer ('(':',':xs) | (a,')':b) <- span (== ',') xs = ("(," ++ a ++ ")") : lexer b
lexer x | Just s <- (bs !!) <$> findIndex (`isPrefixOf` x) bs = s : lexer (drop (length s) x)
    where bs = zipWith (++) openBrackets shutBrackets ++ openBrackets ++ shutBrackets
lexer (x:xs)
    | isSpace x = " " : lexer (dropWhile isSpace xs)
    | isAlpha x || x == '_' =
        let (a,b) = span (\x -> isAlphaNum x || x `elem` "_'#-") xs
            (a1,a2) = spanEnd (== '-') a
        in (x:a1) : lexer (a2 ++ b)
    | isSym x = let (a,b) = span isSym xs in (x:a) : lexer b
    | x == ',' = "," : lexer xs
    | otherwise = lexer xs -- drop invalid bits
lexer [] = []


-- | Find and extract the scope annotations.
--
-- > +package
-- > +module
-- > name.bar
-- > name.++ name.(++) (name.++)
-- > +foo -foo
-- > +scope:foo -scope:foo scope:foo
scope_ :: [String] -> ([Query], [String])
scope_ xs = case xs of
    (readPM -> Just pm):(readCat -> Just cat):":":(readMod -> Just (mod,rest)) -> add pm cat mod rest
    (readPM -> Just pm):(readCat -> Just cat):":-":(readMod -> Just (mod,rest)) -> add False cat mod rest
    (readPM -> Just pm):(readMod -> Just (mod,rest)) -> add_ pm mod rest
    (readCat -> Just cat):":":(readMod -> Just (mod,rest)) -> add True cat mod rest
    (readCat -> Just cat):":.":(readMod -> Just (mod,rest)) -> add True cat ('.':mod) rest
    (readCat -> Just cat):":-":(readMod -> Just (mod,rest)) -> add False cat mod rest
    (readCat -> Just cat):":-.":(readMod -> Just (mod,rest)) -> add False cat ('.':mod) rest
    "(":(readDots -> Just (scp,x:")":rest)) -> out ["(",x,")"] $ add_ True scp rest
    (readDots -> Just (scp,rest)) -> add_ True scp rest
    "(":".":(readDots -> Just (scp,x:")":rest)) -> out ["(",x,")"] $ add_ True ('.':scp) rest
    ".":(readDots -> Just (scp,rest)) -> add_ True ('.':scp) rest
    x:xs -> out [x] $ scope_ xs
    [] -> ([], [])
    where
        out xs (a,b) = (a,xs++b)
        add a b c rest = let (x,y) = scope_ rest in (QueryScope a b c : x, y)
        add_ a c rest = add a b c rest
            where b = if '.' `elem` c || any isUpper (take 1 c) then "module" else "package"

        readPM x = case x of "+" -> Just True; "-" -> Just False; _ -> Nothing

        readCat x | isAlpha1 x = Just x
                  | otherwise = Nothing

        readMod (x:xs) | isAlpha1 x = Just $ case xs of
            ".":ys | Just (a,b) <- readMod ys -> (x ++ "." ++ a, b)
            ".":[] -> (x ++ ".",[])
            ".":" ":ys -> (x ++ "."," ":ys)
            _ -> (x,xs)
        readMod _ = Nothing

        readDots (x:xs) | isAlpha1 x = case xs of
            ".":ys | Just (a,b) <- readDots ys -> Just (x ++ "." ++ a, b)
            ('.':y):ys -> Just (x, [y | y /= ""] ++ ys)
            _ -> Nothing
        readDots _ = Nothing


-- | If everything is a name, or everything is a symbol, then you only have names.
divide :: [String] -> ([String], Maybe (Type ()))
divide xs | all isAlpha1 ns = (ns, Nothing)
          | all isSyms ns = (ns, Nothing)
          | length ns == 1 = (ns, Nothing)
          | otherwise = case break (== "::") xs of
                (nam, _:rest) -> (names_ nam, typeSig_ rest)
                _ -> ([], typeSig_ xs)
    where ns = names_ xs


-- | Ignore brackets around symbols, and try to deal with tuple names.
names_ :: [String] -> [String]
names_ ("(":x:")":xs) = [x | x /= " "] ++ names_ xs
names_ ["(",x] = [x]
names_ (x:xs) = [x | x /= " "] ++ names_ xs
names_ [] = []

typeSig_ :: [String] -> Maybe (Type ())
typeSig_ xs = case parseTypeWithMode parseMode $ unwords $ fixup $ filter (not . all isSpace) xs of
    ParseOk x -> Just $ transformBi (\v -> if v == Ident () "__" then Ident () "_" else v) $ fmap (const ()) x
    _ -> Nothing
    where
        fixup = underscore . closeBracket . completeFunc . completeArrow

        completeArrow (unsnoc -> Just (a,b)) | b `elem` ["-","="] = snoc a (b ++ ">")
        completeArrow x = x

        completeFunc (unsnoc -> Just (a,b)) | b `elem` ["->","=>"] = a ++ [b,"_"]
        completeFunc x = x

        closeBracket xs = xs ++ foldl f [] xs
            where f stack x | Just c <- lookup x (zip openBrackets shutBrackets) = c:stack
                  f (s:tack) x | x == s = tack
                  f stack x = stack

        underscore = replace ["_"] ["__"]


query_test :: IO ()
query_test = testing "Query.parseQuery" $ do
    let want s p (bad,q) = (["missing " ++ s | not $ any p q], filter (not . p) q)
        wantEq v = want (show v) (== v)
        name = wantEq . QueryName
        scope b c v = wantEq $ QueryScope b c v
        typ = wantEq . QueryType . fmap (const ()) . fromParseResult . parseTypeWithMode parseMode
        typpp x = want ("type " ++ x) (\v -> case v of QueryType s -> pretty s == x; _ -> False)
    let infixl 0 ===
        a === f | bad@(_:_) <- fst $ f ([], q) = error $ show (a,q,bad :: [String])
                | otherwise = putChar '.'
            where q = parseQuery a

    "" === id
    "map" === name "map"
    "#" === name "#"
    "c#" === name "c#"
    "-" === name "-"
    "/" === name "/"
    "->" === name "->"
    "foldl'" === name "foldl'"
    "fold'l" === name "fold'l"
    "Int#" === name "Int#"
    "concat map" === name "concat" . name "map"
    "a -> b" === typ "a -> b"
    "a->b" === typ "a -> b"
    "(a b)" === typ "(a b)"
    "map :: a -> b" === typ "a -> b"
    "+Data.Map map" === scope True "module" "Data.Map" . name "map"
    "a -> b package:foo" === scope True "package" "foo" . typ "a -> b"
    "a -> b package:foo-bar" === scope True "package" "foo-bar" . typ "a -> b"
    "Data.Map.map" === scope True "module" "Data.Map" . name "map"
    "[a]" === typ "[a]"
    "++" === name "++"
    "(++)" === name "++"
    ":+:" === name ":+:"
    "bytestring-cvs +hackage" === scope True "package" "hackage" . name "bytestring-cvs"
    "m => c" === typ "m => c"
    "[b ()" === typ "[b ()]"
    "[b (" === typ "[b ()]"
    "_ -> a" === typpp "_ -> a"
    "(a -> b) ->" === typpp "(a -> b) -> _"
    "(a -> b) -" === typpp "(a -> b) -> _"
    "Monad m => " === typpp "Monad m => _"
    "map is:exact" === name "map" . scope True "is" "exact"
    "sort set:hackage" === name "sort" . scope True "set" "hackage"
    "sort -set:hackage" === name "sort" . scope False "set" "hackage"
    "sort set:-hackage" === name "sort" . scope False "set" "hackage"
    "sort -set:-hackage" === name "sort" . scope False "set" "hackage"
    "package:bytestring-csv" === scope True "package" "bytestring-csv"
    "(>>=)" === name ">>="
    "(>>=" === name ">>="
    ">>=" === name ">>="
    "Control.Monad.mplus" === name "mplus" . scope True "module" "Control.Monad"
    "Control.Monad.>>=" === name ">>=" . scope True "module" "Control.Monad"
    "Control.Monad.(>>=)" === name ">>=" . scope True "module" "Control.Monad"
    "(Control.Monad.>>=)" === name ">>=" . scope True "module" "Control.Monad"
    "Control.Monad.(>>=" === name ">>=" . scope True "module" "Control.Monad"
    "(Control.Monad.>>=" === name ">>=" . scope True "module" "Control.Monad"
    "foo.bar" === name "bar" . scope True "package" "foo"
    "insert module:.Map" === name "insert" . scope True "module" ".Map"
    "insert module:Map." === name "insert" . scope True "module" "Map."
    "insert module:.Map." === name "insert" . scope True "module" ".Map."
    ".Map.insert" === name "insert" . scope True "module" ".Map"
    ".Map." === scope True "module" ".Map"
--  FIXME: ".Map" === scope True "module" ".Map" -- probably should work, but really needs to rewrite a fair bit
    "(.Monad.>>=" === name ">>=" . scope True "module" ".Monad"
--  FIXME: "author:Taylor-M.-Hedberg" === scope True "author" "Taylor-M.-Hedberg"
    "author:Bryan-O'Sullivan" === scope True "author" "Bryan-O'Sullivan"
    "\8801" === name "\8801"
    "( )" === id -- FIXME: Should probably be ()