{-# LANGUAGE LambdaCase #-}
module Parser(parseProgram, parseExpression) where

import qualified Control.Exception as E
import Control.Monad
import Control.Monad.Trans
import Data.Char
import Data.Maybe
import System.FilePath
import System.IO.Error (isDoesNotExistError)
import Text.Parsec
import Text.Parsec.Pos

import AST


newtype ParserState = ParserState (Maybe FilePath)
type Parser = ParsecT String ParserState IO


parseProgram :: Maybe FilePath -> String -> IO (Either ParseError Program)
parseProgram mpath = runParserT pProgram (ParserState mpath) (fromMaybe "" mpath)

pProgram :: Parser Program
pProgram = between pWhiteComment eof (liftM Program (many pValue))


parseExpression :: String -> IO (Either ParseError Value)
parseExpression = runParserT pExpression (ParserState Nothing) ""

pExpression :: Parser Value
pExpression = between pWhiteComment eof pValue


pValue :: Parser Value
pValue = pPPC <|> pVEllipsis <|> pVList <|> pVNum <|> pVString <|> pVName <|> pVQuoted  <?> "value"

pVList :: Parser Value
pVList = flip label "list" $ do
    symbol "("
    exs <- many pValue
    symbol ")"
    return $ VList exs

pVNum :: Parser Value
pVNum = liftM (VNum . read) (try ((:) <$> char '-' <*> many1 digit) <|> many1 digit) <* pWhiteComment  <?> "number"

pVString :: Parser Value
pVString = fmap VString pString

pVName :: Parser Value
pVName = flip label "name" $ do
    first <- satisfy isFirstNameChar
    rest <- many (satisfy isNameChar)
    pWhiteComment
    return $ VName $ first : rest
  where
    isNameChar c = ((c >= '*' && c <= 'z') || c `elem` "!$%&|~") && c /= ';'
    isFirstNameChar c = isNameChar c && not (isDigit c)

pVQuoted :: Parser Value
pVQuoted = char '\'' >> liftM VQuoted pValue  <?> "quoted value"

pVEllipsis :: Parser Value
pVEllipsis = symbol "..." >> return VEllipsis  <?> "ellipsis"

pPPC :: Parser Value
pPPC = flip label "preprocessor command" $ do
    symbol "#include"
    incfname <- pString
    ParserState basefname <- getState
    (fname, src) <- liftIO (readPPCinclude basefname incfname)
    stateBackup <- getParserState
    void $ setParserState (State ("(do " ++ src ++ ")") (initialPos fname) (ParserState (Just fname)))
    result <- pValue <* eof
    void $ setParserState stateBackup
    return result


symbol :: String -> Parser ()
symbol s = try (string s) >> pWhiteComment

pString :: Parser String
pString = flip label "string" $ do
    void $ char '"'
    s <- manyTill pStringChar (symbol "\"")
    return s

pStringChar :: Parser Char
pStringChar =
    (char '\\' >>
        choice [ char 'n' >> return '\n'
               , char 'r' >> return '\r'
               , char 't' >> return '\t'
               , char '0' >> return '\0'
               , char 'x' >> pHexDigit >>= \a -> pHexDigit >>= \b -> return (chr (16 * a + b))
               , char '"' >> return '"'
               , char '\\' >> return '\\' ]) <|>
    anyChar
  where
    pHexDigit :: Parser Int
    pHexDigit = (subtract 48 . fromEnum <$> digit)
                    <|> ((+ (10 - 97)) . ord <$> oneOf "abcdef")
                    <|> ((+ (10 - 65)) . ord <$> oneOf "ABCDEF")

pWhiteComment :: Parser ()
pWhiteComment = do
    pWhitespace
    void $ many $ pComment >> pWhitespace
  where
    pWhitespace :: Parser ()
    pWhitespace = void (many space)  <?> "whitespace"

    pComment :: Parser ()
    pComment = flip label "comment" $ do
        void $ char ';'
        void (manyTill anyChar (void endOfLine <|> eof))

readPPCinclude :: Maybe FilePath -> String -> IO (FilePath, String)
readPPCinclude mbase fname =
    let searchDirs = [maybe "." takeDirectory mbase]
        cands = map (</> fname) searchDirs
        tryCand cand = E.tryJust (guard . isDoesNotExistError) (readFile cand) >>= \case
                            Left _ -> return Nothing
                            Right src -> return (Just (cand, src))
    in (catMaybes <$> sequence (map tryCand cands)) >>= \case
            [] -> error $ "Cannot find #include'd file '" ++ fname ++ "'"
            pair : _ -> return pair