#!/usr/bin/env runhaskell

-- vimhl.hs
import Text.Pandoc.JSON
import Text.Regex (mkRegex, splitRegex)
import System.IO
import System.IO.Temp
import System.IO.Error
import System.Directory
import System.FilePath
import System.Process
import Data.Char (toLower)
import Data.Maybe (fromMaybe)
import Control.Arrow (first)
import Control.Monad
import Control.Conditional

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"
                      nmb | "numberLines" `elem` cls =
                              fromMaybe "-1" $ lookup "startfrom" namevals'
                          | otherwise = ""
            colorscheme =
                maybe "" (("-c 'let g:PhColorscheme = \"" ++) . (++ "\"'")) $
                    lookup "colorscheme" namevals'
            cmds =
                maybe "" (unwords . map (cmd . flag) . filter (not . null) .
                            map (splitRegex $ dl"=") . splitRegex (dl",")) $
                                lookup "vars" namevals'
                where cmd (x:y:_) =
                                "--cmd 'let g:" ++ x ++ " = \"" ++ y ++ "\"'"
                      flag [x]    = [x, "1"]
                      flag x      = x
                      dl          = mkRegex . ("\\s*" ++) . (++ "\\s*")
            rccmd = do
                home <- getHomeDirectory `catchIOError` const (return "")
                let vimrc  = home `combine` ".vimrc.pandoc"
                    exists = let (&&>) = liftM2 (<&&>)
                             in doesFileExist &&>
                                 (getPermissions >=> return . readable)
                    ($>) = liftM2 (<$>)
                (bool "" . ("--noplugin -u '" ++) . (++ "'")) $> exists $ vimrc
            runVim src dst hsrc hdst = do
                hPutStr hsrc contents
                mapM_ hClose [hsrc, hdst]
                vimrc <- rccmd
                {- vim must think that it was launched from a terminal,
                 - otherwise it won't load its usual environment and the
                 - syntax engine! -}
                hin <- openFile "/dev/tty" ReadMode
                (_, Just hout, _, handle) <- createProcess (shell $ unwords
                    ["vim -Nen", cmds, vimrc, colorscheme, "-c 'set ft=" ++ ft,
                     "|", vimhlcmd ++ "' -c 'w!", dst ++ "' -c 'qa!'", src])
                    {std_in = UseHandle hin, std_out = CreatePipe}
                waitForProcess handle
                mapM_ hClose [hin, hout]
        block <- withSystemTempFile "_vimhl_src." $
                    \src hsrc -> withSystemTempFile "_vimhl_dst." $
                        \dst hdst -> runVim src dst hsrc hdst >> readFile dst
        return $ RawBlock fm block
    where namevals' = map (first $ map toLower) namevals
vimHl _ cb = return cb

main :: IO ()
main = toJSONFilter vimHl