#!/usr/bin/env runhaskell

-- vimhl.hs
import Text.Pandoc.JSON
import Text.Regex (mkRegex, splitRegex, matchRegexAll)
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 . 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 `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 <- vimrccmd
                {- 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