2bbf98a · typeable/pandoc

git.iko.soy/typeable/pandoc

on master help sign in

Put makeSelfContained in PandocMonad instead of IO.

2bbf98aJohn MacFarlane10 years ago

src/Text/Pandoc/App.hs+1−1

compare with master

unifiedsplit

@@ -409,7 +409,7 @@ convertWithOpts opts = do

409 let htmlFormat = format `elem`

410 ["html","html4","html5","s5","slidy","slideous","dzslides","revealjs"]

411 selfcontain = if optSelfContained opts && htmlFormat

412− then makeSelfContained writerOptions media

412+ then makeSelfContained writerOptions

413 else return

414 handleEntities = if htmlFormat && optAscii opts

415 then toEntities

src/Text/Pandoc/Logging.hs+14−2

@@ -72,6 +72,8 @@ data LogMessage =

72 | CouldNotDetermineImageSize String String

73 | CouldNotDetermineMimeType String

74 | CouldNotConvertTeXMath String String

75+ | CouldNotParseCSS String

76+ | Fetching String

75 deriving (Show, Eq, Data, Ord, Typeable, Generic)

77 deriving (Show, Eq, Data, Ord, Typeable, Generic)

77instance ToJSON LogMessage where

79instance ToJSON LogMessage where

@@ -155,6 +157,12 @@ instance ToJSON LogMessage where

155 ["type" .= String "CouldNotConvertTeXMath",

157 ["type" .= String "CouldNotConvertTeXMath",

156 "contents" .= Text.pack s,

158 "contents" .= Text.pack s,

157 "message" .= Text.pack msg]

159 "message" .= Text.pack msg]

160+ CouldNotParseCSS msg ->

161+ ["type" .= String "CouldNotParseCSS",

162+ "message" .= Text.pack msg]

163+ Fetching fp ->

164+ ["type" .= String "CouldNotParseCSS",

165+ "path" .= Text.pack fp]

158

166

159showPos :: SourcePos -> String

167showPos :: SourcePos -> String

160showPos pos = sn ++ "line " ++

168showPos pos = sn ++ "line " ++

@@ -208,6 +216,10 @@ showLogMessage msg =

208 CouldNotConvertTeXMath s m ->

216 CouldNotConvertTeXMath s m ->

209 "Could not convert TeX math '" ++ s ++ "', rendering as TeX" ++

217 "Could not convert TeX math '" ++ s ++ "', rendering as TeX" ++

210 if null m then "" else (':':'\n':m)

218 if null m then "" else (':':'\n':m)

219+ CouldNotParseCSS m ->

220+ "Could not parse CSS" ++ if null m then "" else (':':'\n':m)

221+ Fetching fp ->

222+ "Fetching " ++ fp ++ "..."

211

223

212messageVerbosity:: LogMessage -> Verbosity

224messageVerbosity:: LogMessage -> Verbosity

213messageVerbosity msg =

225messageVerbosity msg =

@@ -228,5 +240,5 @@ messageVerbosity msg =

228 CouldNotDetermineImageSize{} -> WARNING

240 CouldNotDetermineImageSize{} -> WARNING

229 CouldNotDetermineMimeType{} -> WARNING

241 CouldNotDetermineMimeType{} -> WARNING

230 CouldNotConvertTeXMath{} -> WARNING

242 CouldNotConvertTeXMath{} -> WARNING

231−

243+ CouldNotParseCSS{} -> WARNING

232−

244+ Fetching{} -> INFO

src/Text/Pandoc/SelfContained.hs+43−46

@@ -40,9 +40,7 @@ import System.FilePath (takeExtension, takeDirectory, (</>))

40import Data.Char (toLower, isAscii, isAlphaNum)

41import Codec.Compression.GZip as Gzip

42import qualified Data.ByteString.Lazy as L

43−import Control.Monad.Trans (MonadIO(..))

44−import Text.Pandoc.Shared (renderTags', err, warn, trim)

43+import Text.Pandoc.Shared (renderTags', trim)

45−import Text.Pandoc.MediaBag (MediaBag)

46import Text.Pandoc.MIME (MimeType)

44import Text.Pandoc.MIME (MimeType)

47import Text.Pandoc.UTF8 (toString)

45import Text.Pandoc.UTF8 (toString)

48import Text.Pandoc.Options (WriterOptions(..))

46import Text.Pandoc.Options (WriterOptions(..))

@@ -50,8 +48,11 @@ import Data.List (isPrefixOf)

50import Control.Applicative ((<|>))

48import Control.Applicative ((<|>))

51import Text.Parsec (runParserT, ParsecT)

49import Text.Parsec (runParserT, ParsecT)

52import qualified Text.Parsec as P

50import qualified Text.Parsec as P

51+import Control.Monad.Except (throwError)

53import Control.Monad.Trans (lift)

52import Control.Monad.Trans (lift)

54−import Text.Pandoc.Class (fetchItem, runIO, setMediaBag)

53+import Text.Pandoc.Class (fetchItem, PandocMonad(..), report)

54+import Text.Pandoc.Error

55+import Text.Pandoc.Logging

56isOk :: Char -> Bool

57isOk :: Char -> Bool

57isOk c = isAscii c && isAlphaNum c

58isOk c = isAscii c && isAlphaNum c

@@ -66,8 +67,8 @@ makeDataURI mime raw =

66 then mime ++ ";charset=utf-8"

67 then mime ++ ";charset=utf-8"

67 else mime -- mime type already has charset

68 else mime -- mime type already has charset

69−convertTag :: MediaBag -> Maybe String -> Tag String -> IO (Tag String)

70+convertTag :: PandocMonad m => Maybe String -> Tag String -> m (Tag String)

70−convertTag media sourceURL t@(TagOpen tagname as)

71+convertTag sourceURL t@(TagOpen tagname as)

71 | tagname `elem`

72 | tagname `elem`

72 ["img", "embed", "video", "input", "audio", "source", "track"] = do

73 ["img", "embed", "video", "input", "audio", "source", "track"] = do

73 as' <- mapM processAttribute as

74 as' <- mapM processAttribute as

@@ -75,55 +76,57 @@ convertTag media sourceURL t@(TagOpen tagname as)

75 where processAttribute (x,y) =

76 where processAttribute (x,y) =

76 if x == "src" || x == "data-src" || x == "href" || x == "poster"

77 if x == "src" || x == "data-src" || x == "href" || x == "poster"

77 then do

78 then do

78− enc <- getDataURI media sourceURL (fromAttrib "type" t) y

79+ enc <- getDataURI sourceURL (fromAttrib "type" t) y

79 return (x, enc)

80 return (x, enc)

80 else return (x,y)

81 else return (x,y)

81−convertTag media sourceURL t@(TagOpen "script" as) =

82+convertTag sourceURL t@(TagOpen "script" as) =

82 case fromAttrib "src" t of

83 case fromAttrib "src" t of

83 [] -> return t

84 [] -> return t

84 src -> do

85 src -> do

85− enc <- getDataURI media sourceURL (fromAttrib "type" t) src

86+ enc <- getDataURI sourceURL (fromAttrib "type" t) src

86 return $ TagOpen "script" (("src",enc) : [(x,y) | (x,y) <- as, x /= "src"])

87 return $ TagOpen "script" (("src",enc) : [(x,y) | (x,y) <- as, x /= "src"])

87−convertTag media sourceURL t@(TagOpen "link" as) =

88+convertTag sourceURL t@(TagOpen "link" as) =

88 case fromAttrib "href" t of

89 case fromAttrib "href" t of

89 [] -> return t

90 [] -> return t

90 src -> do

91 src -> do

91− enc <- getDataURI media sourceURL (fromAttrib "type" t) src

92+ enc <- getDataURI sourceURL (fromAttrib "type" t) src

92 return $ TagOpen "link" (("href",enc) : [(x,y) | (x,y) <- as, x /= "href"])

93 return $ TagOpen "link" (("href",enc) : [(x,y) | (x,y) <- as, x /= "href"])

93−convertTag _ _ t = return t

94+convertTag _ t = return t

96+cssURLs :: PandocMonad m

95−cssURLs :: MediaBag -> Maybe String -> FilePath -> ByteString

97+ => Maybe String -> FilePath -> ByteString -> m ByteString

96− -> IO ByteString

97−cssURLs media sourceURL d orig = do

98+cssURLs sourceURL d orig = do

98− res <- runParserT (parseCSSUrls media sourceURL d) () "css" orig

99+ res <- runParserT (parseCSSUrls sourceURL d) () "css" orig

99 case res of

100 case res of

101+ Left e -> do

102+ report $ CouldNotParseCSS (show e)

100− Left e -> warn ("Could not parse CSS: " ++ show e) >> return orig

103+ return orig

101 Right bs -> return bs

104 Right bs -> return bs

102

105

103−parseCSSUrls :: MediaBag -> Maybe String -> FilePath

106+parseCSSUrls :: PandocMonad m

104− -> ParsecT ByteString () IO ByteString

107+ => Maybe String -> FilePath -> ParsecT ByteString () m ByteString

105−parseCSSUrls media sourceURL d = B.concat <$> P.many

108+parseCSSUrls sourceURL d = B.concat <$> P.many

106− (pCSSWhite <|> pCSSComment <|> pCSSUrl media sourceURL d <|> pCSSOther)

109+ (pCSSWhite <|> pCSSComment <|> pCSSUrl sourceURL d <|> pCSSOther)

107

110

108-- Note: some whitespace in CSS is significant, so we can't collapse it!

111-- Note: some whitespace in CSS is significant, so we can't collapse it!

109−pCSSWhite :: ParsecT ByteString () IO ByteString

112+pCSSWhite :: PandocMonad m => ParsecT ByteString () m ByteString

110pCSSWhite = B.singleton <$> P.space <* P.spaces

113pCSSWhite = B.singleton <$> P.space <* P.spaces

111

114

112−pCSSComment :: ParsecT ByteString () IO ByteString

115+pCSSComment :: PandocMonad m => ParsecT ByteString () m ByteString

113pCSSComment = P.try $ do

116pCSSComment = P.try $ do

114 P.string "/*"

117 P.string "/*"

115 P.manyTill P.anyChar (P.try (P.string "*/"))

118 P.manyTill P.anyChar (P.try (P.string "*/"))

116 return B.empty

119 return B.empty

117

120

118−pCSSOther :: ParsecT ByteString () IO ByteString

121+pCSSOther :: PandocMonad m => ParsecT ByteString () m ByteString

119pCSSOther = do

122pCSSOther = do

120 (B.pack <$> P.many1 (P.noneOf "u/ \n\r\t")) <|>

123 (B.pack <$> P.many1 (P.noneOf "u/ \n\r\t")) <|>

121 (B.singleton <$> P.char 'u') <|>

124 (B.singleton <$> P.char 'u') <|>

122 (B.singleton <$> P.char '/')

125 (B.singleton <$> P.char '/')

123

126

124−pCSSUrl :: MediaBag -> Maybe String -> FilePath

127+pCSSUrl :: PandocMonad m

125− -> ParsecT ByteString () IO ByteString

128+ => Maybe String -> FilePath -> ParsecT ByteString () m ByteString

126−pCSSUrl media sourceURL d = P.try $ do

129+pCSSUrl sourceURL d = P.try $ do

127 P.string "url("

130 P.string "url("

128 P.spaces

131 P.spaces

129 quote <- P.option Nothing (Just <$> P.oneOf "\"'")

132 quote <- P.option Nothing (Just <$> P.oneOf "\"'")

@@ -136,30 +139,24 @@ pCSSUrl media sourceURL d = P.try $ do

136 '#':_ -> return fallback

139 '#':_ -> return fallback

137 'd':'a':'t':'a':':':_ -> return fallback

140 'd':'a':'t':'a':':':_ -> return fallback

138 u -> do let url' = if isURI u then u else d </> u

141 u -> do let url' = if isURI u then u else d </> u

139− enc <- lift $ getDataURI media sourceURL "" url'

142+ enc <- lift $ getDataURI sourceURL "" url'

140 return (B.pack $ "url(" ++ enc ++ ")")

143 return (B.pack $ "url(" ++ enc ++ ")")

141

144

142

145

143−getDataURI :: MediaBag -> Maybe String -> MimeType -> String

146+getDataURI :: PandocMonad m => Maybe String -> MimeType -> String -> m String

144− -> IO String

145−getDataURI _ _ _ src@('d':'a':'t':'a':':':_) = return src -- already data: uri

147+getDataURI _ _ src@('d':'a':'t':'a':':':_) = return src -- already data: uri

146−getDataURI media sourceURL mimetype src = do

148+getDataURI sourceURL mimetype src = do

147 let ext = map toLower $ takeExtension src

149 let ext = map toLower $ takeExtension src

148− fetchResult <- runIO $ do setMediaBag media

150+ (raw, respMime) <- fetchItem sourceURL src

149− fetchItem sourceURL src

150− (raw, respMime) <- case fetchResult of

151− Left msg -> err 67 $ "Could not fetch " ++ src ++

152− "\n" ++ show msg

153− Right x -> return x

154 let raw' = if ext == ".gz"

151 let raw' = if ext == ".gz"

155 then B.concat $ L.toChunks $ Gzip.decompress $ L.fromChunks

152 then B.concat $ L.toChunks $ Gzip.decompress $ L.fromChunks

156 $ [raw]

153 $ [raw]

157 else raw

154 else raw

158− let mime = case (mimetype, respMime) of

155+ mime <- case (mimetype, respMime) of

159− ("",Nothing) -> error

156+ ("",Nothing) -> throwError $ PandocSomeError

160 $ "Could not determine mime type for `" ++ src ++ "'"

157 $ "Could not determine mime type for `" ++ src ++ "'"

161− (x, Nothing) -> x

158+ (x, Nothing) -> return x

162− (_, Just x ) -> x

159+ (_, Just x ) -> return x

163 let cssSourceURL = case parseURI src of

160 let cssSourceURL = case parseURI src of

164 Just u

161 Just u

165 | uriScheme u `elem` ["http:","https:"] ->

162 | uriScheme u `elem` ["http:","https:"] ->

@@ -168,14 +165,14 @@ getDataURI media sourceURL mimetype src = do

168 uriFragment = "" }

165 uriFragment = "" }

169 _ -> Nothing

166 _ -> Nothing

170 result <- if mime == "text/css"

167 result <- if mime == "text/css"

171− then cssURLs media cssSourceURL (takeDirectory src) raw'

168+ then cssURLs cssSourceURL (takeDirectory src) raw'

172 else return raw'

169 else return raw'

173 return $ makeDataURI mime result

170 return $ makeDataURI mime result

174

171

175-- | Convert HTML into self-contained HTML, incorporating images,

172-- | Convert HTML into self-contained HTML, incorporating images,

176-- scripts, and CSS using data: URIs.

173-- scripts, and CSS using data: URIs.

177−makeSelfContained :: MonadIO m => WriterOptions -> MediaBag -> String -> m String

174+makeSelfContained :: PandocMonad m => WriterOptions -> String -> m String

178−makeSelfContained opts mediabag inp = liftIO $ do

175+makeSelfContained opts inp = do

179 let tags = parseTags inp

176 let tags = parseTags inp

180− out' <- mapM (convertTag mediabag (writerSourceURL opts)) tags

177+ out' <- mapM (convertTag (writerSourceURL opts)) tags

181 return $ renderTags' out'

178 return $ renderTags' out'