git.iko.soy/typeable/pandoc
on de79021 help sign in
typeable/pandoc/src/markdown2pdf.hs
263 lines 11 kB history raw
1module Main where
3import Data.List (isInfixOf, intercalate, isPrefixOf)
4import Data.Maybe (isNothing)
5import qualified Data.ByteString as BS
6import Codec.Binary.UTF8.String (decodeString, encodeString)
7import Data.ByteString.UTF8 (toString)
8import Control.Monad (unless, guard, liftM, when)
9import Control.Concurrent (putMVar, takeMVar, newEmptyMVar, forkIO)
10import Control.Exception (tryJust, bracket, evaluate)
11import Control.Monad.Trans (liftIO)
12import System.IO.Error (isAlreadyExistsError)
14import System.IO
15import System.IO.Error (isDoesNotExistError)
16import System.Environment ( getArgs, getProgName )
17import qualified Text.Pandoc.UTF8 as UTF8
18import System.Exit (ExitCode (..), exitWith)
19import System.FilePath
20import System.Directory
21import System.Process
23-- A variant of 'readProcessWithExitCode' that does not
24-- cause an error if the output is not UTF-8. (Copied
25-- with slight variants from 'System.Process'.)
26readProcessWithExitCode'
27 :: FilePath -- ^ command to run
28 -> [String] -- ^ any arguments
29 -> String -- ^ standard input
30 -> IO (ExitCode,String,String) -- ^ exitcode, stdout, stderr
31readProcessWithExitCode' cmd args input = do
32 (Just inh, Just outh, Just errh, pid) <-
33 createProcess (proc cmd args){ std_in = CreatePipe,
34 std_out = CreatePipe,
35 std_err = CreatePipe }
37 outMVar <- newEmptyMVar
39 -- fork off a thread to start consuming stdout
40 out <- liftM toString $ BS.hGetContents outh
41 _ <- forkIO $ evaluate (length out) >> putMVar outMVar ()
43 -- fork off a thread to start consuming stderr
44 err <- liftM toString $ BS.hGetContents errh
45 _ <- forkIO $ evaluate (length err) >> putMVar outMVar ()
47 -- now write and flush any input
48 when (not (null input)) $ do hPutStr inh input; hFlush inh
49 hClose inh -- done with stdin
51 -- wait on the output
52 takeMVar outMVar
53 takeMVar outMVar
54 hClose outh
56 -- wait on the process
57 ex <- waitForProcess pid
59 return (ex, out, err)
61run :: FilePath -> [String] -> IO (Either String String)
62run file opts = do
63 (code, out, err) <- readProcessWithExitCode' (encodeString file)
64 (map encodeString opts) ""
65 let msg = out ++ err
66 case code of
67 ExitFailure _ -> return $ Left $! msg
68 ExitSuccess -> return $ Right $! msg
70parsePandocArgs :: [String] -> IO (Maybe ([String], String))
71parsePandocArgs args = do
72 result <- run "pandoc" $ ["--dump-args"] ++ args
73 return $ either error (parse . map trim . lines) result
74 where parse [] = Nothing
75 parse ("-":[]) = Just ([], "stdin") -- no output or input
76 parse ("-":x:xs) = Just (x:xs, dropExtension x) -- no output
77 parse ( x :xs) = Just (xs, dropExtension x) -- at least output
78 --trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
79 trim = takeWhile (/='\r') . dropWhile (=='\r')
81runPandoc :: [String] -> FilePath -> IO (Either String FilePath)
82runPandoc inputsAndArgs output = do
83 let texFile = addExtension output "tex"
84 result <- run "pandoc" $
85 ["-s", "--no-wrap", "-r", "markdown", "-w", "latex"]
86 ++ inputsAndArgs ++ ["-o", texFile]
87 return $ either Left (const $ Right texFile) result
89runLatexRaw :: String -> FilePath -> IO (Either (Either String String) FilePath)
90runLatexRaw latexProgram file = do
91 -- we ignore the ExitCode because pdflatex always fails the first time
92 run latexProgram ["-halt-on-error", "-interaction", "nonstopmode",
93 "-output-directory", takeDirectory file, dropExtension file] >> return ()
94 let pdfFile = replaceExtension file "pdf"
95 let logFile = replaceExtension file "log"
96 txt <- tryJust (guard . isDoesNotExistError)
97 (liftM toString $ BS.readFile logFile)
98 let checks = checkLatex $ either (const "") id txt
99 case checks of
100 -- err , bib , ref , msg
101 (True , _ , _ , msg) -> return $ Left $ Left msg -- failure
102 (False, True , _ , msg) -> runBibtex file >>
103 (return $ Left $ Right msg) -- citations
104 (False, _ , True, msg) -> return $ Left $ Right msg -- references
105 (False, False, False, _ ) -> return $ Right pdfFile -- success
107runLatex :: String -> FilePath -> IO (Either String FilePath)
108runLatex latexProgram file = step 3
109 where
110 step n = do
111 result <- runLatexRaw latexProgram file
112 case result of
113 Left (Left err) -> return $ Left err
114 Left (Right _) | n > 1 -> step (n-1 :: Int)
115 Right _ | n > 2 -> step (n-1 :: Int)
116 Left (Right msg) -> return $ Left msg
117 Right pdfFile -> return $ Right pdfFile
119checkLatex :: String -> (Bool, Bool, Bool, String)
120checkLatex "" = (True, False, False, "Could not read log file")
121checkLatex txt = (err , bib, ref, unlines $! msgs ++ tips)
122 where
123 xs `oneOf` x = any (flip isInfixOf x) xs
124 msgs = dropWhile (not . errorline) $ lines txt
125 errorline ('!':_) = True
126 errorline _ = False
127 tips = checkPackages msgs
128 err = any (oneOf ["!", "LaTeX Error:", "Latex Error:"]) msgs
129 bib = any (oneOf ["Warning: Citation"
130 ,"Warning: There were undefined citations"]) msgs
131 ref = any (oneOf ["Warning: Reference"
132 ,"Warning: Label"
133 ,"Warning: There were undefined references"
134 ]) msgs
136checkPackages :: [String] -> [String]
137checkPackages = concatMap chks
138 where -- for each message, search 'pks' for matches and give a hint
139 chks x = concatMap (chk x) pks
140 chk x (k,v) = if sub k `isInfixOf` x then tip k v else []
141 sub k = "`" ++ k ++ ".sty' not found"
142 tip k v = ["Please install the '" ++ k ++
143 "' package from CTAN:", " " ++ v]
144 pks = [("ucs"
145 ,"http://www.ctan.org/tex-archive/macros/latex/contrib/unicode/")
146 ,("ulem"
147 ,"http://www.ctan.org/tex-archive/macros/latex/contrib/misc/")
148 ,("graphicx"
149 ,"http://www.ctan.org/tex-archive/macros/latex/required/graphics/")
150 ,("fancyhdr"
151 ,"http://www.ctan.org/tex-archive/macros/latex/contrib/fancyhdr/")
152 ,("array"
153 ,"http://www.ctan.org/tex-archive/macros/latex/required/tools/")]
155runBibtex :: FilePath -> IO (Either String FilePath)
156runBibtex file = do
157 let auxFile = replaceExtension file "aux"
158 result <- run "bibtex" [auxFile]
159 return $ either Left (const $ Right auxFile) result
161exit :: String -> IO a
162exit x = do
163 progName <- getProgName
164 UTF8.hPutStrLn stderr $ progName ++ ": " ++ x
165 exitWith $ ExitFailure 1
167saveStdin :: FilePath -> IO (Either String FilePath)
168saveStdin file = do
169 text <- liftM toString $ BS.getContents
170 UTF8.writeFile file text
171 fileExist <- doesFileExist (encodeString file)
172 case fileExist of
173 False -> return $ Left $! "Could not create " ++ file
174 True -> return $ Right file
176saveOutput :: FilePath -> FilePath -> IO ()
177saveOutput input output = do
178 copyFile (encodeString input) (encodeString output)
179 UTF8.hPutStrLn stderr $! "Created " ++ output
181-- | Perform a function in a temporary directory and clean up.
182withTempDir :: FilePath -> (FilePath -> IO a) -> IO a
183withTempDir baseName = bracket (createTempDir 0 baseName) removeDirectoryRecursive
185-- | Create a temporary directory with a unique name.
186createTempDir :: Integer -> FilePath -> IO FilePath
187createTempDir num baseName = do
188 sysTempDir <- getTemporaryDirectory
189 let dirName = sysTempDir </> baseName <.> show num
190 liftIO $ catch (createDirectory dirName >> return dirName) $
191 \e -> if isAlreadyExistsError e
192 then createTempDir (num + 1) baseName
193 else ioError e
195main :: IO ()
196main = withTempDir "pandoc"
197 -- run computation
198 $ \tmp -> do
199 args <- liftM (map decodeString) getArgs
200 -- check for invalid arguments and print help message if needed
201 let goodopts = ["-f","-r","-N", "-p","-R","-H","-B","-A", "-C","-o","-V"]
202 let goodoptslong = ["--from","--read","--strict",
203 "--preserve-tabs","--tab-stop","--parse-raw",
204 "--toc","--table-of-contents", "--xetex", "--luatex",
205 "--number-sections","--include-in-header",
206 "--include-before-body","--include-after-body",
207 "--custom-header","--output",
208 "--template", "--variable",
209 "--csl", "--bibliography", "--data-dir", "--listings"]
210 let isOpt ('-':_) = True
211 isOpt _ = False
212 let opts = filter isOpt args
213 -- note that a long option can come in this form: --opt=val
214 let isGoodopt x = x `elem` (goodopts ++ goodoptslong) ||
215 any (\o -> (o ++ "=") `isPrefixOf` x) goodoptslong
216 let markdown2pdfOpts = ["--xetex","--luatex"]
217 unless (all isGoodopt opts) $ do
218 (code, out, _err) <- readProcessWithExitCode "pandoc" ["--help"] ""
219 UTF8.putStrLn "markdown2pdf [OPTIONS] [FILES]\nOptions:"
220 UTF8.putStr $ unlines $
221 filter (\l -> any (`isInfixOf` l) goodoptslong) (lines out)
222 ++ map (replicate 24 ' ' ++) markdown2pdfOpts
223 exitWith code
225 let args' = filter (`notElem` markdown2pdfOpts) args
227 -- check for executable files
228 let latexProgram = if "--xetex" `elem` opts
229 then "xelatex"
230 else if "--luatex" `elem` opts
231 then "lualatex"
232 else "pdflatex"
233 let execs = ["pandoc", latexProgram, "bibtex"]
234 paths <- mapM findExecutable execs
235 let miss = map snd $ filter (isNothing . fst) $ zip paths execs
236 unless (null miss) $ exit $! "Could not find " ++ intercalate ", " miss
238 -- parse arguments
239 -- if no input given, use 'stdin'
240 pandocArgs <- parsePandocArgs args'
241 (input, output) <- case pandocArgs of
242 Nothing -> exit "Could not parse arguments"
243 Just ([],out) -> do
244 stdinFile <- saveStdin (replaceDirectory (takeBaseName out) tmp)
245 case stdinFile of
246 Left err -> exit err
247 Right f -> return ([f], out)
248 -- no need because we'll pass all arguments to pandoc
249 Just (_ ,out) -> return ([], out)
250 -- run pandoc
251 pandocRes <- runPandoc (input ++ args') $ replaceDirectory output tmp
252 case pandocRes of
253 Left err -> exit err
254 Right texFile -> do
255 -- run pdflatex
256 latexRes <- runLatex latexProgram texFile
257 case latexRes of
258 Left err -> exit err
259 Right pdfFile -> do
260 -- save the output
261 saveOutput pdfFile $
262 replaceDirectory pdfFile (takeDirectory output)