module Main where

import Data.List (isInfixOf, intercalate, (\\))
import Data.Maybe (isNothing)

import Control.Monad (when, unless, guard)
import Control.Exception (tryJust, bracket)

import System.IO (stderr, hPutStrLn)
import System.IO.Error (isDoesNotExistError)
import System.Exit (ExitCode (..), exitWith)
import System.FilePath
import System.Directory
import System.Process (readProcessWithExitCode)
import System.Environment (getArgs, getProgName)


run :: FilePath -> [String] -> IO (Either String String)
run file opts = do
  (code, out, err) <- readProcessWithExitCode file opts ""
  let msg = out ++ err
  case code of
    ExitFailure _ -> return $ Left  $! msg
    ExitSuccess   -> return $ Right $! msg

parsePandocArgs :: [String] -> IO (Maybe ([String], String))
parsePandocArgs args = do
  result <- run "pandoc" $ ["--dump-args"] ++ args
  return $ either (const Nothing) (parse . map trim . lines) result
  where parse []         = Nothing
        parse ("-":[])   = Just ([], "stdin") -- no output or input
        parse ("-":x:xs) = Just (x:xs, dropExtension x) -- no output
        parse ( x :xs)   = Just (xs,   dropExtension x) -- at least output
        --trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
        trim = takeWhile (/='\r') . dropWhile (=='\r')

runPandoc :: [String] -> FilePath -> IO (Either String FilePath)
runPandoc inputs output = do
  let texFile = replaceExtension output "tex"
  result <- run "pandoc" $
    ["-s", "--no-wrap", "-r", "markdown", "-w", "latex"]
    ++ inputs ++ ["-o", texFile]
  return $ either Left (const $ Right texFile) result

runLatexRaw :: FilePath -> IO (Either (Either String String) FilePath)
runLatexRaw file = do
  -- we ignore the ExitCode because pdflatex always fails the first time
  run "pdflatex" ["-interaction=batchmode", "-output-directory",
    takeDirectory file, dropExtension file] >> return ()
  let pdfFile = replaceExtension file "pdf"
  let logFile = replaceExtension file "log"
  txt <- tryJust (guard . isDoesNotExistError) (readFile logFile)
  let  checks = checkLatex $ either (const "") id txt
  case checks of
  -- err  , bib , ref , msg
    (True , _    , _   , msg) -> return $ Left $ Left msg   -- failure
    (False, True , _   , msg) -> runBibtex file >>
                                (return $ Left $ Right msg) -- citations
    (False, _    , True, msg) -> return $ Left $ Right msg  -- references
    (False, False, False, _ ) -> return $ Right pdfFile     -- success

runLatex :: FilePath -> IO (Either String FilePath)
runLatex file = step 3
  where
  step 0 = return $ Left "Limit of attempts reached"
  step n = do
    result <- runLatexRaw file
    case result of
      Left (Left err) -> return $ Left err
      Left (Right _ ) -> step (n-1 :: Int)
      Right pdfFile   -> return $ Right pdfFile

checkLatex :: String -> (Bool, Bool, Bool, String)
checkLatex ""  = (True, False, False, "Could not read log file")
checkLatex txt = (err , bib, ref, unlines $! msgs ++ tips)
  where
  xs `oneOf` x = any (flip isInfixOf x) xs
  msgs = filter (oneOf ["Error:", "Warning:"]) (lines txt)
  tips = checkPackages msgs
  err = any (oneOf ["LaTeX Error:", "Latex Error:"]) msgs
  bib = any (oneOf ["Warning: Citation"
                   ,"Warning: There were undefined citations"]) msgs
  ref = any (oneOf ["Warning: Reference"
                   ,"Warning: Label"
                   ,"Warning: There were undefined references"
                   ,"--toc", "--table-of-contents"]) msgs

checkPackages :: [String] -> [String]
checkPackages = concatMap chks
  where -- for each message, search 'pks' for matches and give a hint
  chks x = concatMap (chk x) pks
  chk x (k,v) = if sub k `isInfixOf` x then tip k v else []
  sub k   = "`" ++ k ++ ".sty' not found"
  tip k v = ["Please install the '" ++ k ++
             "' package from CTAN:", "  " ++ v]
  pks = [("ucs"
         ,"http://www.ctan.org/tex-archive/macros/latex/contrib/unicode/")
        ,("ulem"
         ,"http://www.ctan.org/tex-archive/macros/latex/contrib/misc/")
        ,("graphicx"
         ,"http://www.ctan.org/tex-archive/macros/latex/required/graphics/")
        ,("fancyhdr"
         ,"http://www.ctan.org/tex-archive/macros/latex/contrib/fancyhdr/")
        ,("array"
         ,"http://www.ctan.org/tex-archive/macros/latex/required/tools/")]

runBibtex :: FilePath -> IO (Either String FilePath)
runBibtex file = do
  let auxFile = replaceExtension file "aux"
  result <- run "bibtex" [auxFile]
  return $ either Left (const $ Right auxFile) result

exit :: String -> IO a
exit x = do
  progName <- getProgName
  hPutStrLn stderr $ progName ++ ": " ++ x
  exitWith $ ExitFailure 1

saveStdin :: FilePath -> IO (Either String FilePath)
saveStdin file = do
  text <- getContents
  writeFile file text
  fileExist <- doesFileExist file
  case fileExist of
    False -> return $ Left $! "Could not create " ++ file
    True  -> return $ Right file

saveOutput :: FilePath -> FilePath -> IO ()
saveOutput input output = do
  outputExist <- doesFileExist output
  when outputExist $ do
    let output' = output ++ "~"
    renameFile output output'
    putStrLn $! "Created backup file " ++ output'
  copyFile input output
  putStrLn $! "Created " ++ output

main :: IO ()
main = bracket
  -- acquire resource
  (do dir <- getTemporaryDirectory
      let tmp = dir </> "pandoc"
      createDirectoryIfMissing True tmp
      return tmp)

  -- release resource
  ( \tmp -> removeDirectoryRecursive tmp)

  -- run computation
  $ \tmp -> do
    -- check for executable files
    let execs = ["pandoc", "pdflatex", "bibtex"]
    paths <- mapM findExecutable execs
    let miss = map snd $ filter (isNothing . fst) $ zip paths execs
    unless (null miss) $ exit $! "Could not find " ++ intercalate ", " miss
    args <- getArgs
    -- check for invalid arguments and print help message if needed
    let goodopts = ["-f","-r","--from","--read","--strict","-N",
                   "-p","--preserve-tabs","--tab-stop","-R","--parse-raw",
                   "--toc","--table-of-contents",
                   "--number-sections","-H","--include-in-header",
                   "-B","--include-before-body","-A","--include-after-body",
                   "-C","--custom-header","-o","--output"]
    let goodoptsLong = filter (\op -> length op > 2) goodopts
    let isOpt ('-':_) = True
        isOpt _       = False
    unless (null (filter isOpt args \\ goodopts)) $ do
      (code, out, _err) <- readProcessWithExitCode "pandoc" ["--help"] ""
      putStrLn "markdown2pdf [OPTIONS] [FILES]\nOptions:"
      putStr $ unlines $
               filter (\l -> any (`isInfixOf` l) goodoptsLong) $ lines out
      exitWith code
    -- parse arguments
    pandocArgs <- parsePandocArgs args
    (inputs, output) <- case pandocArgs of
      Nothing     -> exit "Could not parse arguments"
      Just ([],out) -> do
        stdinFile <- saveStdin (replaceDirectory (takeBaseName out) tmp)
        case stdinFile of
          Left err  -> exit err
          Right f   -> return ([f], out)
      Just (fs,out) -> return (fs, out)
    -- run pandoc
    pandocRes <- runPandoc (args ++ inputs) $ replaceDirectory output tmp
    case pandocRes of
      Left err -> exit err
      Right texFile  -> do
        -- run pdflatex
        latexRes <- runLatex texFile
        case latexRes of
          Left err      -> exit err
          Right pdfFile -> do
            -- save the output creating a backup if necessary
            saveOutput pdfFile $
              replaceDirectory pdfFile (takeDirectory output)