{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
{- |
   Module      : Text.DocTemplates.Parser
   Copyright   : Copyright (C) 2009-2019 John MacFarlane
   License     : BSD3

   Maintainer  : John MacFarlane <jgm@berkeley.edu>
   Stability   : alpha
   Portability : portable
-}

module Text.DocTemplates.Parser
    ( compileTemplate ) where

import Data.Char (isAlphaNum)
import Control.Monad (guard, when)
import Control.Monad.Trans (lift)
import qualified Text.Parsec as P
import qualified Text.Parsec.Pos as P
import Control.Applicative
import Data.String (IsString(..))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Read as T
import Data.List (isPrefixOf)
import System.FilePath
import Text.DocTemplates.Internal
import qualified Text.DocLayout as DL
#if MIN_VERSION_base(4,11,0)
#else
import Data.Semigroup ((<>), Semigroup)
#endif

-- | Compile a template.  The FilePath parameter is used
-- to determine a default path and extension for partials
-- and may be left empty if partials are not used.
compileTemplate :: (TemplateMonad m, TemplateTarget a)
                => FilePath -> Text -> m (Either String (Template a))
compileTemplate templPath template = do
  res <- P.runParserT (pTemplate <* P.eof)
           PState{ templatePath    = templPath
                 , partialNesting  = 1
                 , breakingSpaces  = False
                 , firstNonspace   = P.initialPos templPath
                 , nestedCol       = Nothing
                 , insideDirective = False
                 } templPath template
  case res of
       Left e   -> return $ Left $ show e
       Right x  -> return $ Right x


data PState =
  PState { templatePath    :: FilePath
         , partialNesting  :: !Int
         , breakingSpaces  :: !Bool
         , firstNonspace   :: P.SourcePos
         , nestedCol       :: Maybe Int
         , insideDirective :: Bool
         }

type Parser = P.ParsecT Text PState

pTemplate :: (TemplateMonad m, TemplateTarget a) => Parser m (Template a)
pTemplate = do
  P.skipMany pComment
  mconcat <$> many
    ((pLit <|> pNewline <|> pDirective <|>
      pEscape) <* P.skipMany pComment)

pEndline :: Monad m => Parser m String
pEndline = P.try $ do
  nls <- pLineEnding
  mbNested <- nestedCol <$> P.getState
  inside <- insideDirective <$> P.getState
  case mbNested of
    Just col -> do
      P.skipMany $ do
        P.getPosition >>= guard . (< col) . P.sourceColumn
        P.char ' ' <|> P.char '\t'
      curcol <- P.sourceColumn <$> P.getPosition
      guard $ inside || curcol >= col
    Nothing  ->  return ()
  return nls

pBlankLine :: (TemplateTarget a, Monad m) => Parser m (Template a)
pBlankLine =
  P.try $ Literal . fromString <$> pLineEnding <* P.lookAhead pNewlineOrEof

pNewline :: (TemplateTarget a, Monad m) => Parser m (Template a)
pNewline = P.try $ do
  nls <- pEndline
  sps <- P.many (P.char ' ' <|> P.char '\t')
  breakspaces <- breakingSpaces <$> P.getState
  pos <- P.getPosition
  P.updateState $ \st -> st{ firstNonspace = pos }
  return $ Literal $
    if breakspaces
       then DL.BreakingSpace
       else fromString $ nls <> sps

pLit :: (TemplateTarget a, Monad m) => Parser m (Template a)
pLit = do
  cs <- P.many1 (P.satisfy (\c -> c /= '$' && c /= '\n' && c /= '\r'))
  when (all (\c -> c == ' ' || c == '\t') cs) $ do
     pos <- P.getPosition
     when (P.sourceLine pos == 1) $
       P.updateState $ \st -> st{ firstNonspace = pos }
  breakspaces <- breakingSpaces <$> P.getState
  if breakspaces
     then return $ toBreakable cs
     else return $ Literal $ fromString cs

toBreakable :: TemplateTarget a => String -> Template a
toBreakable [] = Empty
toBreakable xs =
  case break isSpacy xs of
    ([], []) -> Empty
    ([], zs) -> Literal DL.BreakingSpace <>
                   toBreakable (dropWhile isSpacy zs)
    (ys, []) -> Literal (fromString ys)
    (ys, zs) -> Literal (fromString ys) <> toBreakable zs

isSpacy :: Char -> Bool
isSpacy ' '  = True
isSpacy '\n' = True
isSpacy '\r' = True
isSpacy '\t' = True
isSpacy _    = False

backupSourcePos :: Monad m => Int -> Parser m ()
backupSourcePos n = do
  pos <- P.getPosition
  P.setPosition $ P.incSourceColumn pos (- n)

pEscape :: (TemplateTarget a, Monad m) => Parser m (Template a)
pEscape = Literal "$" <$ P.try (P.string "$$" <* backupSourcePos 1)

pDirective :: (TemplateTarget a, TemplateMonad m)
           => Parser m (Template a)
pDirective = do
  res <- pConditional <|> pForLoop <|> pReflowToggle <|> pNested <|>
         pInterpolate <|> pBarePartial
  return res

pEnclosed :: Monad m => Parser m a -> Parser m a
pEnclosed parser = P.try $ do
  closer <- pOpen
  P.skipMany pSpaceOrTab
  result <- parser
  P.skipMany pSpaceOrTab
  closer
  return result

pParens :: Monad m => Parser m a -> Parser m a
pParens parser = do
  P.char '('
  result <- parser
  P.char ')'
  return result

pInside :: Monad m
        => Parser m (Template a)
        -> Parser m (Template a)
pInside parser = do
  oldInside <- insideDirective <$> P.getState
  P.updateState $ \st -> st{ insideDirective = True }
  res <- parser
  P.updateState $ \st -> st{ insideDirective = oldInside }
  return res

pConditional :: (TemplateTarget a, TemplateMonad m)
             => Parser m (Template a)
pConditional = do
  v <- pEnclosed $ P.try $ P.string "if" *> pParens pVar
  pInside $ do
    multiline <- P.option False (True <$ skipEndline)
    -- if newline after the "if", then a newline after "endif" will be swallowed
    ifContents <- pTemplate
    elseContents <- P.option mempty (pElse multiline <|> pElseIf)
    pEnclosed (P.string "endif")
    when multiline $ P.option () skipEndline
    return $ Conditional v ifContents elseContents

pElse :: (TemplateTarget a, TemplateMonad m)
      => Bool -> Parser m (Template a)
pElse multiline = do
  pEnclosed (P.string "else")
  when multiline $ P.option () skipEndline
  pTemplate

pElseIf :: (TemplateTarget a, TemplateMonad m) => Parser m (Template a)
pElseIf = do
  v <- pEnclosed $ P.try $ P.string "elseif" *> pParens pVar
  multiline <- P.option False (True <$ skipEndline)
  ifContents <- pTemplate
  elseContents <- P.option mempty (pElse multiline <|> pElseIf)
  return $ Conditional v ifContents elseContents

skipEndline :: Monad m => Parser m ()
skipEndline = do
  pEndline
  pos <- P.lookAhead $ do
           P.skipMany (P.char ' ' <|> P.char '\t')
           P.getPosition
  P.updateState $ \st -> st{ firstNonspace = pos }

pReflowToggle :: (Monoid a, Semigroup a, TemplateMonad m)
              => Parser m (Template a)
pReflowToggle = do
  pEnclosed $ P.char '~'
  P.modifyState $ \st -> st{ breakingSpaces = not (breakingSpaces st) }
  return mempty

pNested :: (TemplateTarget a, TemplateMonad m) => Parser m (Template a)
pNested = do
  col <- P.sourceColumn <$> P.getPosition
  pEnclosed $ P.char '^'
  oldNested <- nestedCol <$> P.getState
  P.updateState $ \st -> st{ nestedCol = Just col }
  x <- pTemplate
  xs <- P.many $ P.try $ do
          y <- mconcat <$> P.many1 pBlankLine
          z <- pTemplate
          return (y <> z)
  let contents = x <> mconcat xs
  P.updateState $ \st -> st{ nestedCol = oldNested }
  return $ Nested $ contents

pForLoop :: (TemplateTarget a, TemplateMonad m) => Parser m (Template a)
pForLoop = do
  v <- pEnclosed $ P.try $ P.string "for" *> pParens pVar
  -- if newline after the "for", then a newline after "endfor" will be swallowed
  pInside $ do
    multiline <- P.option False $ skipEndline >> return True
    contents <- changeToIt v <$> pTemplate
    sep <- P.option mempty $
             do pEnclosed (P.string "sep")
                when multiline $ P.option () skipEndline
                changeToIt v <$> pTemplate
    pEnclosed (P.string "endfor")
    when multiline $ P.option () skipEndline
    return $ Iterate v contents sep

changeToIt :: (Semigroup a) => Variable -> Template a -> Template a
changeToIt v = go
 where
  go (Interpolate w) = Interpolate (reletter v w)
  go (Conditional w t1 t2) = Conditional (reletter v w)
        (changeToIt v t1) (changeToIt v t2)
  go (Iterate w t1 t2) = Iterate (reletter v w)
        (changeToIt v t1) (changeToIt v t2)
  go (Concat t1 t2) = changeToIt v t1 <> changeToIt v t2
  go (Partial fs t) = Partial fs t  -- don't reletter inside partial
  go (Nested t) = Nested (go t)
  go x = x
  reletter (Variable vs _fs) (Variable ws gs) =
    if vs `isPrefixOf` ws
       then Variable ("it" : drop (length vs) ws) gs
       else Variable ws gs

pInterpolate :: (TemplateTarget a, TemplateMonad m)
             => Parser m (Template a)
pInterpolate = do
  pos <- P.getPosition
  -- we don't used pEnclosed here, to get better error messages:
  (closer, var) <- P.try $ do
    cl <- pOpen
    P.skipMany pSpaceOrTab
    v <- pVar
    P.notFollowedBy (P.char '(') -- bare partial
    return (cl, v)
  res <- (P.char ':' *> (pPartialName >>= pPartial (Just var)))
      <|> Iterate var (Interpolate (Variable ["it"] [])) <$> pSep
      <|> return (Interpolate var)
  P.skipMany pSpaceOrTab
  closer
  handleNesting False pos res

pLineEnding :: Monad m => Parser m String
pLineEnding = P.string "\n" <|> P.try (P.string "\r\n") <|> P.string "\r"

pNewlineOrEof :: Monad m => Parser m ()
pNewlineOrEof = () <$ pLineEnding <|> P.eof

handleNesting :: TemplateMonad m
              => Bool -> P.SourcePos -> Template a -> Parser m (Template a)
handleNesting eatEndline pos templ = do
  firstNonspacePos <- firstNonspace <$> P.getState
  let beginline = firstNonspacePos == pos
  endofline <- (True <$ P.lookAhead pNewlineOrEof) <|> pure False
  when (eatEndline && beginline) $ P.optional skipEndline
  mbNested <- nestedCol <$> P.getState
  let toNested t@(Nested{}) = t
      toNested t = case P.sourceColumn pos of
                     1 -> t
                     n | Just n == mbNested -> t
                       | otherwise          -> Nested t
  return $ if beginline && endofline
              then toNested templ
              else templ

pBarePartial :: (TemplateTarget a, TemplateMonad m)
             => Parser m (Template a)
pBarePartial = do
  pos <- P.getPosition
  (closer, fp) <- P.try $ do
    closer <- pOpen
    P.skipMany pSpaceOrTab
    fp <- pPartialName
    return (closer, fp)
  res <- pPartial Nothing fp
  P.skipMany pSpaceOrTab
  closer
  handleNesting True pos res

pPartialName :: TemplateMonad m
             => Parser m FilePath
pPartialName = P.try $ do
  fp <- P.many1 (P.alphaNum <|> P.oneOf ['_','-','.','/','\\'])
  P.string "()"
  return fp

pPartial :: (TemplateTarget a, TemplateMonad m)
         => Maybe Variable -> FilePath -> Parser m (Template a)
pPartial mbvar fp = do
  oldst <- P.getState
  separ <- P.option mempty pSep
  tp <- templatePath <$> P.getState
  let fp' = case takeExtension fp of
               "" -> replaceBaseName tp fp
               _  -> replaceFileName tp fp
  partial <- lift $ removeFinalNewline <$> getPartial fp'
  nesting <- partialNesting <$> P.getState
  t <- if nesting > 50
          then return $ Literal "(loop)"
          else do
            oldInput <- P.getInput
            oldPos <- P.getPosition
            P.setPosition $ P.initialPos fp'
            P.setInput partial
            P.updateState $ \st -> st{ partialNesting = nesting + 1 }
            P.updateState $ \st -> st{ nestedCol = Nothing }
            res' <- pTemplate <* P.eof
            P.updateState $ \st -> st{ partialNesting = nesting }
            P.setInput oldInput
            P.setPosition oldPos
            return res'
  P.putState oldst
  fs <- many pPipe
  case mbvar of
    Just var -> return $ Iterate var (Partial fs t) separ
    Nothing  -> return $ Partial fs t

removeFinalNewline :: Text -> Text
removeFinalNewline t =
  case T.unsnoc t of
    Just (t', '\n') -> t'
    _ -> t

pSep :: (TemplateTarget a, Monad m) => Parser m (Template a)
pSep = do
    P.char '['
    xs <- P.many (P.satisfy (/= ']'))
    P.char ']'
    return $ Literal (fromString xs)

pSpaceOrTab :: Monad m => Parser m Char
pSpaceOrTab = P.satisfy (\c -> c == ' ' || c == '\t')

pComment :: Monad m => Parser m ()
pComment = do
  pos <- P.getPosition
  P.try (P.string "$--")
  P.skipMany (P.satisfy (/='\n'))
  -- If the comment begins in the first column, the line ending
  -- will be consumed; otherwise not.
  when (P.sourceColumn pos == 1) $ () <$ pNewlineOrEof

pOpenDollar :: Monad m => Parser m (Parser m ())
pOpenDollar =
  pCloseDollar <$ P.try (P.char '$' <*
                   P.notFollowedBy (P.char '$' <|> P.char '{'))
  where
   pCloseDollar = () <$ P.char '$'

pOpenBraces :: Monad m => Parser m (Parser m ())
pOpenBraces =
  pCloseBraces <$ P.try (P.string "${" <* P.notFollowedBy (P.char '}'))
  where
   pCloseBraces = () <$ P.try (P.char '}')

pOpen :: Monad m => Parser m (Parser m ())
pOpen = pOpenDollar <|> pOpenBraces

pVar :: Monad m => Parser m Variable
pVar = do
  first <- pIdentPart <|> pIt
  rest <- P.many (P.char '.' *> pIdentPart)
  pipes <- P.many pPipe
  return $ Variable (first:rest) pipes

pPipe :: Monad m => Parser m Pipe
pPipe = do
  P.char '/'
  pipeName <- P.many1 P.letter
  P.notFollowedBy P.letter
  case pipeName of
    "uppercase" -> return ToUppercase
    "lowercase" -> return ToLowercase
    "pairs"     -> return ToPairs
    "length"    -> return ToLength
    "alpha"     -> return ToAlpha
    "roman"     -> return ToRoman
    "reverse"   -> return Reverse
    "chomp"     -> return Chomp
    "nowrap"    -> return NoWrap
    "left"      -> Block LeftAligned <$> pBlockWidth <*> pBlockBorders
    "right"     -> Block RightAligned <$> pBlockWidth <*> pBlockBorders
    "center"    -> Block Centered <$> pBlockWidth <*> pBlockBorders
    _           -> fail $ "Unknown pipe " ++ pipeName

pBlockWidth :: Monad m => Parser m Int
pBlockWidth = P.try (do
  _ <- P.many1 P.space
  ds <- P.many1 P.digit
  case T.decimal (T.pack ds) of
        Right (n,"") -> return n
        _            -> fail "Expected integer parameter for pipe") P.<?>
          "integer parameter for pipe"

pBlockBorders :: Monad m => Parser m Border
pBlockBorders = do
  P.skipMany P.space
  let pBorder = do
        P.char '"'
        cs <- P.many $ (P.noneOf ['"','\\']) <|> (P.char '\\' >> P.anyChar)
        P.char '"'
        P.skipMany P.space
        return $ T.pack cs
  Border <$> P.option mempty pBorder <*> P.option mempty pBorder

pIt :: Monad m => Parser m Text
pIt = fromString <$> P.try (P.string "it")

pIdentPart :: Monad m => Parser m Text
pIdentPart = P.try $ do
  first <- P.letter
  rest <- P.many (P.satisfy (\c -> isAlphaNum c || c == '_' || c == '-'))
  let part = first : rest
  guard $ part `notElem` reservedWords
  return $ fromString part

reservedWords :: [String]
reservedWords = ["if","else","endif","elseif","for","endfor","sep","it"]