import Text.Pandoc.JSON
import Text.Regex (mkRegex, splitRegex, matchRegexAll)
import System.IO (IOMode (WriteMode), openFile, hFlush)
import System.IO.Temp
import System.IO.Error
import System.Directory
import System.FilePath
import System.Process
import System.Exit
import Data.Char (toLower)
import Data.Maybe (fromMaybe)
import Control.Arrow ((&&&), (***))
import Control.Monad
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
import Control.Exception (bracket)
import Control.Conditional hiding (unless)
#if MIN_VERSION_pandoc_types(1,20,0)
import Prelude hiding (readFile)
import Data.Text.IO (readFile, hPutStr)
import Data.Text (Text, unpack)
#else
import System.IO (hPutStr)
#endif

#if MIN_VERSION_pandoc_types(1,20,0)
tOSTRING :: Text -> String
tOSTRING = unpack
#else
tOSTRING :: String -> String
tOSTRING = id
#endif

vimHl :: Maybe Format -> Block -> IO Block
vimHl (Just fm@(Format fmt)) (CodeBlock (_, cls@(ft:_), namevals) contents)
    | lookup "hl" namevals' == Just "vim" && fmt' `elem` ["html", "latex"] = do
        let vimhlcmd =
                unwords [cmd fmt', nmb]
                where cmd "html"  = "MakeHtmlCodeHighlight"
                      cmd "latex" = "MakeTexCodeHighlight"
                      cmd x       = error $ "Unexpected format '" ++ x ++ "'"
                      nmb | "numberLines" `elem` cls' =
                              fromMaybe "-1" $ lookup "startfrom" namevals'
                          | otherwise = ""
            colorscheme =
                maybe "" (("-c 'let g:PhColorscheme = \"" ++) . (++ "\"'")) $
                    lookup "colorscheme" namevals'
            cmds =
                maybe "" (unwords . map cmd . filter (not . null . snd) .
                    map (matchRegexAll (dl"=") &&& id) . splitRegex (dl",")) $
                        lookup "vars" namevals'
                where cmd (Nothing, x) = mkCmd x "1"
                      cmd (Just ("", _, y, _), _) =
                          error $ "Bare value '" ++ y ++ "' found in vars"
                      cmd (Just (x, _, y, _), _) = mkCmd x y
                      mkCmd x y = "--cmd 'let g:" ++ x ++ " = \"" ++ y ++ "\"'"
                      dl = mkRegex . ("\\s*" ++) . (++ "\\s*")
        vimrccmd <- do
            home <- getHomeDirectory `catchIOError` const (return "")
            let vimrc  = home </> ".vimrc.pandoc"
                exists = doesFileExist &&>
                    (getPermissions >=> return . readable)
                (&&>) = liftM2 (<&&>)
                ($>)  = liftM2 (<$>)
            (bool "" . ("--noplugin -u '" ++) . (++ "'")) $> exists $ vimrc
        block <- withSystemTempFile "_vimhl_src." $ \src hsrc -> do
            hPutStr hsrc contents >> hFlush hsrc
            bracket (emptySystemTempFile "_vimhl_dst.") removeFile $
                \dst -> do
                    let vimcmd =
                            unwords
                                ["vim -Nen", cmds, vimrccmd, colorscheme
                                ,"-c 'set ft=" ++ ft', "|"
                                ,vimhlcmd ++ "' -c 'w!", dst ++ "' -c 'qa!'"
                                ,src
                                ]
#ifdef DEBUG
                    hPutStr stderr $ vimcmd ++ " ... "
#endif
                    {- vim must think that it was launched from a terminal,
                     - otherwise it won't load its usual environment and the
                     - syntax engine! Using WriteMode for stdin prevents vim
                     - from getting unresponsive on Ctrl-C interrupts while
                     - still doing well its task (vim checks that input is a
                     - terminal using isatty(), however it does not check the
                     - mode of the handle). -}
                    hin <- openFile "/dev/tty" WriteMode
                    hout <- openFile "/dev/null" WriteMode
                    (_, _, _, handle) <- createProcess (shell vimcmd)
                        {std_in = UseHandle hin, std_out = UseHandle hout}
                    r <- waitForProcess handle
                    unless (r == ExitSuccess) $ exitWith r
#ifdef DEBUG
                    hPutStrLn stderr "done"
#endif
                    readFile dst
        return $ RawBlock fm block
    where fmt' = tOSTRING fmt
          cls' = map tOSTRING cls
          ft'  = tOSTRING ft
          namevals' = map (map toLower . tOSTRING *** tOSTRING) namevals
vimHl _ cb = return cb

main :: IO ()
main = toJSONFilter vimHl