git.iko.soy/typeable/pandoc
on 83bb1de help sign in
typeable/pandoc/src/markdown2pdf.hs
269 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 -> [String] -> FilePath -> IO (Either String FilePath)
82runPandoc outputFormat inputsAndArgs output = do
83 let texFile = addExtension output "tex"
84 result <- run "pandoc" $
85 ["-s", "--no-wrap", "-r", "markdown", "-w", outputFormat]
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 "--no-highlight", "--highlight-style",
210 "--citation-abbreviations", "--old-dashes",
211 "--csl", "--bibliography", "--data-dir", "--listings",
212 "--beamer"]
213 let isOpt ('-':_) = True
214 isOpt _ = False
215 let opts = filter isOpt args
216 -- note that a long option can come in this form: --opt=val
217 let isGoodopt x = x `elem` (goodopts ++ goodoptslong) ||
218 any (\o -> (o ++ "=") `isPrefixOf` x) goodoptslong
219 let markdown2pdfOpts = ["--xetex","--luatex", "--beamer"]
220 unless (all isGoodopt opts) $ do
221 (code, out, _err) <- readProcessWithExitCode "pandoc" ["--help"] ""
222 UTF8.putStrLn "markdown2pdf [OPTIONS] [FILES]\nOptions:"
223 UTF8.putStr $ unlines $
224 filter (\l -> any (`isInfixOf` l) goodoptslong) (lines out)
225 ++ map (replicate 24 ' ' ++) markdown2pdfOpts
226 exitWith code
228 let args' = filter (`notElem` markdown2pdfOpts) args
230 -- check for executable files
231 let latexProgram = if "--xetex" `elem` opts
232 then "xelatex"
233 else if "--luatex" `elem` opts
234 then "lualatex"
235 else "pdflatex"
236 let outputFormat = if "--beamer" `elem` opts
237 then "beamer"
238 else "latex"
239 let execs = ["pandoc", latexProgram, "bibtex"]
240 paths <- mapM findExecutable execs
241 let miss = map snd $ filter (isNothing . fst) $ zip paths execs
242 unless (null miss) $ exit $! "Could not find " ++ intercalate ", " miss
244 -- parse arguments
245 -- if no input given, use 'stdin'
246 pandocArgs <- parsePandocArgs args'
247 (input, output) <- case pandocArgs of
248 Nothing -> exit "Could not parse arguments"
249 Just ([],out) -> do
250 stdinFile <- saveStdin (replaceDirectory (takeBaseName out) tmp)
251 case stdinFile of
252 Left err -> exit err
253 Right f -> return ([f], out)
254 -- no need because we'll pass all arguments to pandoc
255 Just (_ ,out) -> return ([], out)
256 -- run pandoc
257 pandocRes <- runPandoc outputFormat (input ++ args') $ replaceDirectory output tmp
258 case pandocRes of
259 Left err -> exit err
260 Right texFile -> do
261 -- run pdflatex
262 latexRes <- runLatex latexProgram texFile
263 case latexRes of
264 Left err -> exit err
265 Right pdfFile -> do
266 -- save the output
267 saveOutput pdfFile $
268 replaceDirectory pdfFile (takeDirectory output)