{- Copyright 2013-2021 NGLess Authors
 - License: MIT
 -}
{-# LANGUAGE CPP #-}

module Parse
    ( parsengless
#ifdef IS_BUILDING_TEST
    , _nglbody
    , _cleanupindents
    , _indexexpr
    , _listexpr
#endif
    ) where

import Control.Monad
import Control.Monad.Identity ()
import qualified Data.Text as T
import Text.ParserCombinators.Parsec.Prim hiding (Parser)
import Text.Parsec.Combinator
import Text.Parsec.Pos
import Text.Parsec.Error
import Data.Functor (($>))

import NGLess.NGError
import Language
import Tokens (tokenize, Token(..))


sliceList :: Int -> Int -> [a] -> [a]
sliceList st e = take (e - st) . drop st

-- | main function of this module
--
-- Because the scripts are expected to be small, we load them whole into memory
-- (with a strict 'Text') before parsing
parsengless :: String -- ^ input filename (for error messages)
            -> Bool -- ^ whether the version statement is mandatory
            -> T.Text -- ^ input data
            -> NGLess Script -- ^ either error message or parsed 'Script'
parsengless inputname reqversion input = tokenize inputname input >>= parsetoks input inputname reqversion

parsetoks :: T.Text -> String -> Bool -> [(SourcePos,Token)] -> NGLess Script
parsetoks input inputname reqversion toks = case parse (nglparser reqversion) inputname (_cleanupindents toks) of
            Right val -> return val
            Left err -> throwScriptError $ buildErrorMessage input err


buildErrorMessage :: T.Text -> ParseError -> String
buildErrorMessage input err = concat $ ["Parsing error on file '", fname, "' on line ", show line, " (column ", show col, ")\n\n"]
                    ++ preLines 3
                    ++ ["\n\t", indicatorLine]
                    ++ postLines 2
                    ++ ["\n\n", show err, "\n"]
    where
        pos = errorPos err
        fname = sourceName pos
        line = sourceLine pos
        col = sourceColumn pos
        sourceLines = T.unpack <$> T.lines input
        preLines :: Int -> [String]
        preLines n = withNLTAB $ sliceList (max 0 (line - n)) line sourceLines
        postLines n = withNLTAB $ sliceList line (line +  n) sourceLines
        withNLTAB [] = []
        withNLTAB (ell:ls) = "\n\t":ell:withNLTAB ls
        indicatorLine = ['-' | _ <- [1..col+8]] ++ "^"


-- | '_cleanupindents' removes spaces that do not follow new lines as well as
-- any spaces that are between brackets (round or square).
_cleanupindents ::[(SourcePos,Token)] -> [(SourcePos, Token)]
_cleanupindents = _cleanupindents' []
    where
        _cleanupindents' _ [] = []
        _cleanupindents' cs (t@(_,TOperator o):ts)
                | isOpen o = t : _cleanupindents' (closeOf o:cs) ts
        _cleanupindents' (c:cs) (t@(_,TOperator c'):ts)
                | c' == c = t : _cleanupindents' cs ts
        _cleanupindents' cs@(_:_) ((_,TNewLine):ts) = _cleanupindents' cs ts
        _cleanupindents' cs@(_:_) ((_,TIndent _):ts) = _cleanupindents' cs ts
        _cleanupindents' [] ((_,TNewLine):(_,TIndent _):t0@(_,TNewLine):ts) = _cleanupindents' [] (t0:ts)
        _cleanupindents' [] (t0@(_,TNewLine):t1@(_,TIndent _):ts) = t0 : t1 : _cleanupindents' [] ts
        _cleanupindents' [] ((_,TIndent _):ts) = _cleanupindents' [] ts
        _cleanupindents' cs (t:ts) = t : _cleanupindents' cs ts

        isOpen '(' = True
        isOpen '[' = True
        isOpen _ = False
        closeOf '[' = ']'
        closeOf '(' = ')'
        closeOf _ = error "we should not close anything but [ & ("

type Parser = GenParser (SourcePos,Token) ()

nglparser False = Script <$> optionMaybe ngless_header <*> (many eol *> _nglbody)
nglparser True = Script <$> (Just <$> ngless_header) <*> (many eol *> _nglbody)
_nglbody = (eof *> pure []) <|> (many1 lno_expression <* eof)
lno_expression = (,) <$> linenr <*> expression
    where linenr = sourceLine `fmap` getPosition

expression :: Parser Expression
expression = expression' <* many eol
    where
        expression' =
                    conditional
                    <|> (reserved "discard" $> Discard)
                    <|> (reserved "continue" $> Continue)
                    <|> assignment
                    <|> innerexpression

innerexpression = try $ do
    left <- left_expression
    (try $ do {
        bop <- binop;
        right <- innerexpression;
        return $ BinaryOp bop left right}) <|> return left

left_expression =  uoperator
                    <|> method_call
                    <|> _indexexpr
                    <|> base_expression

base_expression = pexpression
                    <|> (funccall <?> "function call")
                    <|> _listexpr
                    <|> rawexpr
                    <|> (Lookup Nothing <$> variable)

pexpression = operator '(' *> innerexpression <* operator ')'

tokf ::  (Token -> Maybe a) -> Parser a
tokf f = token (show .snd) fst (f . snd)

rawexpr = tokf $ \case
    TExpr e -> Just e
    _ -> Nothing
string = (tokf $ \case { TExpr (ConstStr n) -> Just n; _ -> Nothing }) <?> "String"

operator op = (tokf $ \t -> case t of { TOperator op' | op == op' -> Just t; _ -> Nothing }) <?> (concat ["operator ", [op]])

word = tokf $ \case
    TWord w -> Just w
    _ -> Nothing

match_word w = (tokf $ \case
    TWord w' | w == w' -> Just w
    _ -> Nothing) <?> ("word "++T.unpack w)
reserved r = (tokf $ \case { TReserved r' | r == r' -> Just r; _ -> Nothing }) <?> (concat [T.unpack r, " (reserved word)"])

indentation = (tokf $ \case { TIndent i -> Just i; _ -> Nothing }) <?> "indentation"
eol = (tokf $ \case { TNewLine -> Just (); _ -> Nothing }) <?> "end of line"
binop = (tokf $ \case { TBop b -> Just b; _ -> Nothing }) <?> "binary operator"

uoperator = lenop <|> unary_minus <|> not_expr
    where
        lenop = UnaryOp UOpLen <$> (reserved "len" *> operator '(' *> expression <* operator ')')
        unary_minus = UnaryOp UOpMinus <$> (operator '-' *> base_expression)
        not_expr = UnaryOp UOpNot <$> (reserved "not" *> innerexpression)
funccall = try paired <|> FunctionCall <$>
                try (funcname <* operator '(')
                <*> innerexpression
                <*> (kwargs <* operator ')')
                <*> funcblock

funcblock = optionMaybe (Block <$> (reserved "using" *> operator '|' *> variable <* operator '|' <* operator ':') <*> block)

paired = FunctionCall
            <$> (match_word "paired" $> (FuncName "paired"))
            <*> (operator '(' *> innerexpression <* operator ',')
            <*> pairedKwArgs
            <*> pure Nothing

funcname = FuncName   <$> word <?> "function name"
method   = MethodName <$> word <?> "method name"

pairedKwArgs = (++) <$> (wrap <$> expression) <*> (kwargs <* operator ')')
    where wrap e = [(Variable "second", e)]

kwargs = many (operator ',' *> kwarg) <?> "keyword argument list"
kwarg = kwarg' <?> "keyword argument"
    where kwarg' = (,) <$> (variable <* operator '=') <*> innerexpression

assignment = try assignment'
    where assignment' =
            Assignment <$> variable <*> (operator '=' *> expression)

method_call = try $ do
    self <- base_expression <* operator '.'
    met <- method <* operator '('
    a <- optionMaybe $ try (innerexpression <* notFollowedBy (operator '='))
    optional (operator ',')
    kws <- kwarg `sepBy` (operator ',')
    void $ operator ')'
    return (MethodCall met self a kws)

_indexexpr = try (IndexExpression <$> base_expression <*> indexing)
    where
        indexing = try (IndexTwo <$> (operator '[' *> may_int <* operator ':') <*> (may_int <* operator ']'))
                    <|> (IndexOne <$> (operator '[' *> innerexpression <* operator ']'))
        may_int = optionMaybe innerexpression

_listexpr = try listexpr
    where
        listexpr = (operator '[') *> (ListExpression <$> (innerexpression `sepEndBy` (operator ','))) <* (operator ']')

conditional = Condition <$> (reserved "if" *> innerexpression <* operator ':') <*> block <*> mayelse
mayelse = elseblock <|> pure (Sequence [])
elseblock = reserved "else" *> operator ':' *> block
block = do
        eol
        level <- indentation
        first <- expression <* many eol
        rest <- block' level
        return $ Sequence (first:rest)
    where
        block' level = many (try $ do
                            level' <- indentation
                            if level /= level'
                                then fail "indentation changed"
                                else expression <* many eol)
variable = Variable <$> word <?> "variable"

ngless_header = Header <$> (many eol *> ngless_version <* many eol) <*> many (import_mod <* many eol)
ngless_version = ngless_version' <?> "ngless version declararion"
    where ngless_version' = reserved "ngless" *> (string <?> "ngless version string") <* eol

import_mod =
        LocalModInfo <$> (reserved "local" *> reserved "import" *> (string <?> "module name")) <*> (match_word "version" *> (string <?> "module version")) <* eol
        <|>
        ModInfo <$> (reserved "import" *> (string <?> "module name")) <*> (match_word "version" *> (string <?> "module version")) <* eol