1{-# LANGUAGE CPP                 #-}
2{-# LANGUAGE FlexibleContexts    #-}
3{-# LANGUAGE OverloadedStrings   #-}
4{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE TupleSections       #-}
6{- |
7   Module      : Text.Pandoc.App
8   Copyright   : Copyright (C) 2006-2021 John MacFarlane
9   License     : GNU GPL, version 2 or above
10
11   Maintainer  : John MacFarlane <jgm@berkeley@edu>
12   Stability   : alpha
13   Portability : portable
14
15Does a pandoc conversion based on command-line options.
16-}
17module Text.Pandoc.App.OutputSettings
18  ( OutputSettings (..)
19  , optToOutputSettings
20  ) where
21import qualified Data.Map as M
22import qualified Data.Text as T
23import Text.DocTemplates (toVal, Context(..), Val(..))
24import qualified Control.Exception as E
25import Control.Monad
26import Control.Monad.Except (throwError)
27import Control.Monad.Trans
28import Data.Char (toLower)
29import Data.List (find)
30import Data.Maybe (fromMaybe)
31import Skylighting (defaultSyntaxMap)
32import Skylighting.Parser (addSyntaxDefinition, parseSyntaxDefinition)
33import System.Directory (getCurrentDirectory)
34import System.Exit (exitSuccess)
35import System.FilePath
36import System.IO (stdout)
37import Text.Pandoc
38import Text.Pandoc.App.FormatHeuristics (formatFromFilePaths)
39import Text.Pandoc.App.Opt (Opt (..))
40import Text.Pandoc.App.CommandLineOptions (engines, lookupHighlightStyle,
41                                          setVariable)
42import qualified Text.Pandoc.UTF8 as UTF8
43
44readUtf8File :: PandocMonad m => FilePath -> m T.Text
45readUtf8File = fmap UTF8.toText . readFileStrict
46
47-- | Settings specifying how document output should be produced.
48data OutputSettings = OutputSettings
49  { outputFormat :: T.Text
50  , outputWriter :: Writer PandocIO
51  , outputWriterName :: T.Text
52  , outputWriterOptions :: WriterOptions
53  , outputPdfProgram :: Maybe String
54  }
55
56-- | Get output settings from command line options.
57optToOutputSettings :: Opt -> PandocIO OutputSettings
58optToOutputSettings opts = do
59  let outputFile = fromMaybe "-" (optOutputFile opts)
60
61  when (optDumpArgs opts) . liftIO $ do
62    UTF8.hPutStrLn stdout (T.pack outputFile)
63    mapM_ (UTF8.hPutStrLn stdout . T.pack) (fromMaybe [] $ optInputFiles opts)
64    exitSuccess
65
66  epubMetadata <- traverse readUtf8File $ optEpubMetadata opts
67
68  let pdfOutput = map toLower (takeExtension outputFile) == ".pdf" ||
69                  optTo opts == Just "pdf"
70  (writerName, maybePdfProg) <-
71    if pdfOutput
72       then liftIO $ pdfWriterAndProg
73               (case optTo opts of
74                  Just "pdf" -> Nothing
75                  x          -> x)
76               (optPdfEngine opts)
77       else case optTo opts of
78              Just f -> return (f, Nothing)
79              Nothing
80               | outputFile == "-" -> return ("html", Nothing)
81               | otherwise ->
82                     case formatFromFilePaths [outputFile] of
83                           Nothing -> do
84                             report $ CouldNotDeduceFormat
85                                [T.pack $ takeExtension outputFile] "html"
86                             return ("html", Nothing)
87                           Just f  -> return (f, Nothing)
88
89  let format = if ".lua" `T.isSuffixOf` writerName
90                  then writerName
91                  else T.toLower $ baseWriterName writerName
92
93  (writer :: Writer PandocIO, writerExts) <-
94            if ".lua" `T.isSuffixOf` format
95               then return (TextWriter
96                       (\o d -> writeCustom (T.unpack writerName) o d)
97                               :: Writer PandocIO, mempty)
98               else getWriter (T.toLower writerName)
99
100  let standalone = optStandalone opts || not (isTextFormat format) || pdfOutput
101
102  let addSyntaxMap existingmap f = do
103        res <- liftIO (parseSyntaxDefinition f)
104        case res of
105              Left errstr -> throwError $ PandocSyntaxMapError $ T.pack errstr
106              Right syn   -> return $ addSyntaxDefinition syn existingmap
107
108  syntaxMap <- foldM addSyntaxMap defaultSyntaxMap
109                     (optSyntaxDefinitions opts)
110
111  hlStyle <- traverse (lookupHighlightStyle . T.unpack) $ optHighlightStyle opts
112
113  let setVariableM k v = return . setVariable k v
114
115  let setListVariableM _ [] ctx = return ctx
116      setListVariableM k vs ctx = do
117        let ctxMap = unContext ctx
118        return $ Context $
119          case M.lookup k ctxMap of
120              Just (ListVal xs) -> M.insert k
121                                  (ListVal $ xs ++ map toVal vs) ctxMap
122              Just v -> M.insert k
123                         (ListVal $ v : map toVal vs) ctxMap
124              Nothing -> M.insert k (toVal vs) ctxMap
125
126  let getTextContents fp = UTF8.toText . fst <$> fetchItem (T.pack fp)
127
128  let setFilesVariableM k fps ctx = do
129        xs <- mapM getTextContents fps
130        setListVariableM k xs ctx
131
132  curdir <- liftIO getCurrentDirectory
133
134  variables <-
135    return (optVariables opts)
136    >>=
137    setListVariableM "sourcefile"
138      (maybe ["-"] (fmap T.pack) (optInputFiles opts))
139    >>=
140    setVariableM "outputfile" (T.pack outputFile)
141    >>=
142    setFilesVariableM "include-before" (optIncludeBeforeBody opts)
143    >>=
144    setFilesVariableM "include-after" (optIncludeAfterBody opts)
145    >>=
146    setFilesVariableM "header-includes" (optIncludeInHeader opts)
147    >>=
148    setListVariableM "css" (map T.pack $ optCss opts)
149    >>=
150    maybe return (setVariableM "title-prefix") (optTitlePrefix opts)
151    >>=
152    maybe return (setVariableM "epub-cover-image")
153                 (T.pack <$> optEpubCoverImage opts)
154    >>=
155    setVariableM "curdir" (T.pack curdir)
156    >>=
157    (\vars ->  if format == "dzslides"
158                  then do
159                      dztempl <- UTF8.toText <$> readDataFile
160                                   ("dzslides" </> "template.html")
161                      let dzline = "<!-- {{{{ dzslides core"
162                      let dzcore = T.unlines
163                                 $ dropWhile (not . (dzline `T.isPrefixOf`))
164                                 $ T.lines dztempl
165                      setVariableM "dzslides-core" dzcore vars
166                  else return vars)
167
168  templ <- case optTemplate opts of
169                  _ | not standalone -> return Nothing
170                  Nothing -> Just <$> compileDefaultTemplate format
171                  Just tp -> do
172                    -- strip off extensions
173                    let tp' = case takeExtension tp of
174                                   "" -> tp <.> T.unpack format
175                                   _  -> tp
176                    res <- getTemplate tp' >>= runWithPartials . compileTemplate tp'
177                    case res of
178                      Left  e -> throwError $ PandocTemplateError $ T.pack e
179                      Right t -> return $ Just t
180
181  let writerOpts = def {
182          writerTemplate         = templ
183        , writerVariables        = variables
184        , writerTabStop          = optTabStop opts
185        , writerTableOfContents  = optTableOfContents opts
186        , writerHTMLMathMethod   = optHTMLMathMethod opts
187        , writerIncremental      = optIncremental opts
188        , writerCiteMethod       = optCiteMethod opts
189        , writerNumberSections   = optNumberSections opts
190        , writerNumberOffset     = optNumberOffset opts
191        , writerSectionDivs      = optSectionDivs opts
192        , writerExtensions       = writerExts
193        , writerReferenceLinks   = optReferenceLinks opts
194        , writerReferenceLocation = optReferenceLocation opts
195        , writerDpi              = optDpi opts
196        , writerWrapText         = optWrap opts
197        , writerColumns          = optColumns opts
198        , writerEmailObfuscation = optEmailObfuscation opts
199        , writerIdentifierPrefix = optIdentifierPrefix opts
200        , writerHtmlQTags        = optHtmlQTags opts
201        , writerTopLevelDivision = optTopLevelDivision opts
202        , writerListings         = optListings opts
203        , writerSlideLevel       = optSlideLevel opts
204        , writerHighlightStyle   = hlStyle
205        , writerSetextHeaders    = optSetextHeaders opts
206        , writerEpubSubdirectory = T.pack $ optEpubSubdirectory opts
207        , writerEpubMetadata     = epubMetadata
208        , writerEpubFonts        = optEpubFonts opts
209        , writerEpubChapterLevel = optEpubChapterLevel opts
210        , writerTOCDepth         = optTOCDepth opts
211        , writerReferenceDoc     = optReferenceDoc opts
212        , writerSyntaxMap        = syntaxMap
213        , writerPreferAscii      = optAscii opts
214        }
215  return $ OutputSettings
216    { outputFormat = format
217    , outputWriter = writer
218    , outputWriterName = writerName
219    , outputWriterOptions = writerOpts
220    , outputPdfProgram = maybePdfProg
221    }
222
223baseWriterName :: T.Text -> T.Text
224baseWriterName = T.takeWhile (\c -> c /= '+' && c /= '-')
225
226pdfWriterAndProg :: Maybe T.Text              -- ^ user-specified writer name
227                 -> Maybe String              -- ^ user-specified pdf-engine
228                 -> IO (T.Text, Maybe String) -- ^ IO (writerName, maybePdfEngineProg)
229pdfWriterAndProg mWriter mEngine =
230  case go mWriter mEngine of
231      Right (writ, prog) -> return (writ, Just prog)
232      Left err           -> liftIO $ E.throwIO $ PandocAppError err
233    where
234      go Nothing Nothing       = Right ("latex", "pdflatex")
235      go (Just writer) Nothing = (writer,) <$> engineForWriter writer
236      go Nothing (Just engine) = (,engine) <$> writerForEngine (takeBaseName engine)
237      go (Just writer) (Just engine) =
238           case find (== (baseWriterName writer, takeBaseName engine)) engines of
239                Just _  -> Right (writer, engine)
240                Nothing -> Left $ "pdf-engine " <> T.pack engine <>
241                           " is not compatible with output format " <> writer
242
243      writerForEngine eng = case [f | (f,e) <- engines, e == eng] of
244                                 fmt : _ -> Right fmt
245                                 []      -> Left $
246                                   "pdf-engine " <> T.pack eng <> " not known"
247
248      engineForWriter "pdf" = Left "pdf writer"
249      engineForWriter w = case [e |  (f,e) <- engines, f == baseWriterName w] of
250                                eng : _ -> Right eng
251                                []      -> Left $
252                                   "cannot produce pdf output from " <> w
253
254isTextFormat :: T.Text -> Bool
255isTextFormat s =
256  s `notElem` ["odt","docx","epub2","epub3","epub","pptx","pdf"]
257