{-# LANGUAGE LambdaCase #-}
module Erb.Parser where

import Text.Parsec.String
import Text.Parsec.Prim hiding ((<|>),many)
import Text.Parsec.Char
import Text.Parsec.Error
import Text.Parsec.Combinator hiding (optional)
import Text.Parsec.Language (emptyDef)
import Erb.Ruby
import Text.Parsec.Expr
import Text.Parsec.Pos
import qualified Text.Parsec.Token as P
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Control.Monad.Identity
import Control.Exception (catch,SomeException)
import Control.Applicative

def :: P.GenLanguageDef String u Identity
def = emptyDef
    { P.commentStart   = "/*"
    , P.commentEnd     = "*/"
    , P.commentLine    = "#"
    , P.nestedComments = True
    , P.identStart     = letter
    , P.identLetter    = alphaNum <|> oneOf "_"
    , P.reservedNames  = ["if", "else", "case", "elsif"]
    , P.reservedOpNames= ["=>","=","+","-","/","*","+>","->","~>","!"]
    , P.caseSensitive  = True
    }

lexer :: P.GenTokenParser String u Identity
lexer = P.makeTokenParser def

parens :: Parser a -> Parser a
parens = P.parens lexer

braces :: Parser a -> Parser a
braces = P.braces lexer

operator :: Parser String
operator = P.operator lexer

symbol :: String -> Parser String
symbol = P.symbol lexer

reservedOp :: String -> Parser ()
reservedOp = P.reservedOp lexer

whiteSpace :: Parser ()
whiteSpace = P.whiteSpace lexer

naturalOrFloat :: Parser (Either Integer Double)
naturalOrFloat = P.naturalOrFloat lexer

identifier :: Parser String
identifier = P.identifier lexer

rubyexpression :: Parser Expression
rubyexpression = buildExpressionParser table term <?> "expression"

table :: [[Operator String () Identity Expression]]
table =     [ [ Infix  ( reservedOp "+" >> return PlusOperation        ) AssocLeft
              , Infix  ( reservedOp "-" >> return MinusOperation       ) AssocLeft ]
            , [ Infix  ( reservedOp "/" >> return DivOperation         ) AssocLeft
              , Infix  ( reservedOp "*" >> return MultiplyOperation    ) AssocLeft ]
            , [ Infix  ( reservedOp "<<" >> return ShiftLeftOperation  ) AssocLeft
              , Infix  ( reservedOp ">>" >> return ShiftRightOperation ) AssocLeft ]
            , [ Infix  ( reservedOp "and" >> return AndOperation       ) AssocLeft
              , Infix  ( reservedOp "or" >> return OrOperation         ) AssocLeft ]
            , [ Infix  ( reservedOp "==" >> return EqualOperation      ) AssocLeft
              , Infix  ( reservedOp "!=" >> return DifferentOperation  ) AssocLeft ]
            , [ Infix  ( reservedOp ">" >> return AboveOperation       ) AssocLeft
              , Infix  ( reservedOp ">=" >> return AboveEqualOperation ) AssocLeft
              , Infix  ( reservedOp "<=" >> return UnderEqualOperation ) AssocLeft
              , Infix  ( reservedOp "<" >> return UnderOperation       ) AssocLeft ]
            , [ Infix  ( reservedOp "=~" >> return RegexpOperation     ) AssocLeft
              , Infix  ( reservedOp "!~" >> return NotRegexpOperation  ) AssocLeft ]
            , [ Prefix ( symbol "!" >> return NotOperation             )           ]
            , [ Prefix ( symbol "-" >> return NegOperation             )           ]
            , [ Infix  ( reservedOp "?" >> return ConditionalValue     ) AssocLeft ]
            , [ Infix  ( reservedOp "." >> return MethodCall           ) AssocLeft ]
            ]
term :: Parser Expression
term
    =   parens rubyexpression
    <|> scopeLookup
    <|> stringLiteral
    <|> objectterm
    <|> variablereference

scopeLookup :: Parser Expression
scopeLookup = do
    void $ try $ string "scope"
    end <- (string ".lookupvar(" >> return (char ')')) <|> (char '[' >> return (char ']'))
    expr <- rubyexpression
    void end
    return $ Object expr

stringLiteral :: Parser Expression
stringLiteral = Value `fmap` (doubleQuoted <|> singleQuoted)

doubleQuoted :: Parser Value
doubleQuoted = Interpolable <$> between (char '"') (char '"') quoteInternal
    where
        quoteInternal = many (basicContent <|> interpvar <|> escaped)
        escaped = char '\\' >> (Value . Literal . T.singleton) `fmap` anyChar
        basicContent = (Value . Literal . T.pack) `fmap` many1 (noneOf "\"\\#")
        interpvar = do
            void $ try (string "#{")
            o <- many1 (noneOf "}")
            void $ char '}'
            return (Object (Value (Literal (T.pack o))))

singleQuoted :: Parser Value
singleQuoted = Literal . T.pack <$> between (char '\'') (char '\'') (many $ noneOf "'")

objectterm :: Parser Expression
objectterm = do
    void $ optional (char '@')
    methodname' <- fmap T.pack identifier
    let methodname = Value (Literal methodname')
    lookAhead anyChar >>= \case
        '[' -> do
            hr <- many (symbol "[" *> rubyexpression <* symbol "]")
            return $! foldl LookupOperation (Object methodname) hr
        '{' -> fmap (MethodCall methodname . BlockOperation . T.pack) (braces (many1 $ noneOf "}"))
        '(' -> fmap (MethodCall methodname . Value . Array) (parens (rubyexpression `sepBy` symbol ","))
        _ -> return $ Object methodname

variablereference :: Parser Expression
variablereference = fmap (Object . Value . Literal . T.pack) identifier

rubystatement :: Parser RubyStatement
rubystatement = fmap Puts rubyexpression

textblockW :: Maybe Char ->  Parser [RubyStatement]
textblockW c = do
    s <- many (noneOf "<")
    let ns = case c of
            Just x  -> x:s
            Nothing -> s
        returned = Puts $ Value $ Literal $ T.pack ns
    optionMaybe eof >>= \case
        Just _  -> return [returned]
        Nothing -> do
            void $ char '<'
            n <- optionMaybe (char '%') >>= \case
                Just _  -> rubyblock
                Nothing -> textblockW (Just '<')
            return (returned : n)

textblock :: Parser [RubyStatement]
textblock = textblockW Nothing

rubyblock :: Parser [RubyStatement]
rubyblock = do
    ps <- option [] (char '-' >> return [DropPrevSpace'])
    parsed <- optionMaybe (char '=') >>= \case
        Just _  -> spaces >> fmap (return . Puts) rubyexpression
        Nothing -> spaces >> many1 rubystatement
    spaces
    let dn (x:xs) = DropNextSpace x : xs
        dn x = x
    ns <- option id (char '-' >> return dn)
    void $ string "%>"
    n <- textblock
    return (ps ++ parsed ++ ns n)

erbparser :: Parser [RubyStatement]
erbparser = textblock

parseErbFile :: FilePath -> IO (Either ParseError [RubyStatement])
parseErbFile fname = parseContent `catch` handler
    where
        parseContent = (runParser erbparser () fname . T.unpack) `fmap` T.readFile fname
        handler e = let msg = show (e :: SomeException)
                    in  return $ Left $ newErrorMessage (Message msg) (initialPos fname)

parseErbString :: String -> Either ParseError [RubyStatement]
parseErbString = runParser erbparser () "dummy"