. -- Assumes notes are sorted. footnoteSection :: PandocMonad m => WriterOptions -> ReferenceLocation -> Int -> [Html] -> StateT WriterState m Html footnoteSection opts refLocation startCounter notes = do html5 <- gets stHtml5 slideVariant <- gets stSlideVariant let hrtag = if refLocation /= EndOfBlock then (if html5 then H5.hr else H.hr) else mempty let additionalClassName = case refLocation of EndOfBlock -> "footnotes-end-of-block" EndOfDocument -> "footnotes-end-of-document" EndOfSection -> "footnotes-end-of-section" let className = "footnotes " <> additionalClassName epubVersion <- gets stEPUBVersion let container x | html5 , epubVersion == Just EPUB3 = H5.section ! A.class_ className ! customAttribute "epub:type" "footnotes" $ x | html5 = H5.section ! A.class_ className ! customAttribute "role" "doc-endnotes" $ x | slideVariant /= NoSlides = H.div ! A.class_ "footnotes slide" $ x | otherwise = H.div ! A.class_ className $ x return $ if null notes then mempty else do nl opts container $ do nl opts hrtag nl opts -- Keep the previous output exactly the same if we don't -- have multiple notes sections if startCounter == 1 then H.ol $ mconcat notes >> nl opts else H.ol ! A.start (fromString (show startCounter)) $ mconcat notes >> nl opts nl opts -- | Parse a mailto link; return Just (name, domain) or Nothing. parseMailto :: Text -> Maybe (Text, Text) parseMailto s = case T.break (==':') s of (xs,T.uncons -> Just (':',addr)) | T.toLower xs == "mailto" -> do let (name', rest) = T.span (/='@') addr let domain = T.drop 1 rest return (name', domain) _ -> Prelude.fail "not a mailto: URL" -- | Obfuscate a "mailto:" link. obfuscateLink :: PandocMonad m => WriterOptions -> Attr -> Html -> Text -> StateT WriterState m Html obfuscateLink opts attr txt s | writerEmailObfuscation opts == NoObfuscation = addAttrs opts attr $ H.a ! A.href (toValue s) $ txt obfuscateLink opts attr (TL.toStrict . renderHtml -> txt) s = let meth = writerEmailObfuscation opts s' = T.toLower (T.take 7 s) <> T.drop 7 s in case parseMailto s' of (Just (name', domain)) -> let domain' = T.replace "." " dot " domain at' = obfuscateChar '@' (linkText, altText) = if txt == T.drop 7 s' -- autolink then ("e", name' <> " at " <> domain') else ("'" <> obfuscateString txt <> "'", txt <> " (" <> name' <> " at " <> domain' <> ")") (_, classNames, _) = attr classNamesStr = T.concat $ map (" "<>) classNames in case meth of ReferenceObfuscation -> -- need to use preEscapedString or &'s are escaped to & in URL return $ preEscapedText $ " obfuscateString s' <> "\" class=\"email\">" <> obfuscateString txt <> "" JavascriptObfuscation -> return $ (H.script ! A.type_ "text/javascript" $ preEscapedText ("\n\n")) >> H.noscript (preEscapedText $ obfuscateString altText) _ -> throwError $ PandocSomeError $ "Unknown obfuscation method: " <> tshow meth _ -> addAttrs opts attr $ H.a ! A.href (toValue s) $ toHtml txt -- malformed email -- | Obfuscate character as entity. obfuscateChar :: Char -> Text obfuscateChar char = let num = ord char numstr = if even num then show num else "x" <> showHex num "" in "&#" <> T.pack numstr <> ";" -- | Obfuscate string using entities. obfuscateString :: Text -> Text obfuscateString = T.concatMap obfuscateChar . fromEntities -- | Create HTML tag with attributes. tagWithAttributes :: WriterOptions -> Bool -- ^ True for HTML5 -> Bool -- ^ True if self-closing tag -> Text -- ^ Tag text -> Attr -- ^ Pandoc style tag attributes -> Text tagWithAttributes opts html5 selfClosing tagname attr = let mktag = (TL.toStrict . renderHtml <$> evalStateT (addAttrs opts attr (customLeaf (textTag tagname) selfClosing)) defaultWriterState{ stHtml5 = html5 }) in case runPure mktag of Left _ -> mempty Right t -> t addAttrs :: PandocMonad m => WriterOptions -> Attr -> Html -> StateT WriterState m Html addAttrs opts attr h = foldl' (!) h <$> attrsToHtml opts attr toAttrs :: PandocMonad m => [(Text, Text)] -> StateT WriterState m [Attribute] toAttrs kvs = do html5 <- gets stHtml5 mbEpubVersion <- gets stEPUBVersion reverse . snd <$> foldM (go html5 mbEpubVersion) (Set.empty, []) kvs where go html5 mbEpubVersion (keys, attrs) (k,v) = do if k `Set.member` keys then do report $ DuplicateAttribute k v return (keys, attrs) else return (Set.insert k keys, addAttr html5 mbEpubVersion k v attrs) addAttr html5 mbEpubVersion x y | html5 = if x `Set.member` (html5Attributes <> rdfaAttributes) || T.any (== ':') x -- e.g. epub: namespace || "data-" `T.isPrefixOf` x || "aria-" `T.isPrefixOf` x then (customAttribute (textTag x) (toValue y) :) else (customAttribute (textTag ("data-" <> x)) (toValue y) :) | mbEpubVersion == Just EPUB2 , not (x `Set.member` (html4Attributes <> rdfaAttributes) || "xml:" `T.isPrefixOf` x) = id | otherwise = (customAttribute (textTag x) (toValue y) :) attrsToHtml :: PandocMonad m => WriterOptions -> Attr -> StateT WriterState m [Attribute] attrsToHtml opts (id',classes',keyvals) = do attrs <- toAttrs keyvals return $ [prefixedId opts id' | not (T.null id')] ++ [A.class_ (toValue $ T.unwords classes') | not (null classes')] ++ attrs imgAttrsToHtml :: PandocMonad m => WriterOptions -> Attr -> StateT WriterState m [Attribute] imgAttrsToHtml opts attr = do attrs <- attrsToHtml opts (ident,cls,kvs') dimattrs <- toAttrs (dimensionsToAttrList attr) return $ attrs ++ dimattrs where (ident,cls,kvs) = attr kvs' = filter isNotDim kvs isNotDim ("width", _) = False isNotDim ("height", _) = False isNotDim _ = True dimensionsToAttrList :: Attr -> [(Text, Text)] dimensionsToAttrList attr = consolidateStyles $ go Width ++ go Height where consolidateStyles :: [(Text, Text)] -> [(Text, Text)] consolidateStyles xs = case partition isStyle xs of ([], _) -> xs (ss, rest) -> ("style", T.intercalate ";" $ map snd ss) : rest isStyle ("style", _) = True isStyle _ = False go dir = case dimension dir attr of (Just (Pixel a)) -> [(tshow dir, tshow a)] (Just x) -> [("style", tshow dir <> ":" <> tshow x)] Nothing -> [] figure :: PandocMonad m => WriterOptions -> Attr -> [Inline] -> (Text, Text) -> StateT WriterState m Html figure opts attr@(_, _, attrList) txt (s,tit) = do html5 <- gets stHtml5 -- Screen-readers will normally read the @alt@ text and the figure; we -- want to avoid them reading the same text twice. With HTML5 we can -- use aria-hidden for the caption; with HTML4, we use an empty -- alt-text instead. -- When the alt text differs from the caption both should be read. let alt = if html5 then txt else [Str ""] let tocapt = if html5 then (H5.figcaption !) $ if isJust (lookup "alt" attrList) then mempty else H5.customAttribute (textTag "aria-hidden") (toValue @Text "true") else H.p ! A.class_ "caption" img <- inlineToHtml opts (Image attr alt (s,tit)) capt <- if null txt then return mempty else tocapt `fmap` inlineListToHtml opts txt return $ if html5 then H5.figure $ mconcat [nl opts, img, capt, nl opts] else H.div ! A.class_ "figure" $ mconcat [nl opts, img, nl opts, capt, nl opts] adjustNumbers :: WriterOptions -> [Block] -> [Block] adjustNumbers opts doc = if all (==0) (writerNumberOffset opts) then doc else walk go doc where go (Header level (ident,classes,kvs) lst) = Header level (ident,classes,map fixnum kvs) lst go x = x fixnum ("number",num) = ("number", showSecNum $ zipWith (+) (writerNumberOffset opts ++ repeat 0) (map (fromMaybe 0 . safeRead) $ T.split (=='.') num)) fixnum x = x showSecNum = T.intercalate "." . map tshow blockToHtmlInner :: PandocMonad m => WriterOptions -> Block -> StateT WriterState m Html blockToHtmlInner opts (Plain lst) = inlineListToHtml opts lst blockToHtmlInner opts (Para [Image attr@(_,classes,_) txt (src,tit)]) | "stretch" `elem` classes = do slideVariant <- gets stSlideVariant case slideVariant of RevealJsSlides -> -- a "stretched" image in reveal.js must be a direct child -- of the slide container inlineToHtml opts (Image attr txt (src, tit)) _ -> figure opts attr txt (src, tit) -- title beginning with fig: indicates that the image is a figure blockToHtmlInner opts (Para [Image attr txt (s,T.stripPrefix "fig:" -> Just tit)]) = figure opts attr txt (s,tit) blockToHtmlInner opts (Para lst) = do contents <- inlineListToHtml opts lst case contents of Empty _ | not (isEnabled Ext_empty_paragraphs opts) -> return mempty _ -> return $ H.p contents blockToHtmlInner opts (LineBlock lns) = if writerWrapText opts == WrapNone then blockToHtml opts $ linesToPara lns else do htmlLines <- inlineListToHtml opts $ intercalate [LineBreak] lns return $ H.div ! A.class_ "line-block" $ htmlLines blockToHtmlInner opts (Div (ident, "section":dclasses, dkvs) (Header level hattr@(hident,hclasses,hkvs) ils : xs)) = do slideVariant <- gets stSlideVariant slideLevel <- gets stSlideLevel let slide = slideVariant /= NoSlides && level <= slideLevel {- DROPPED old fix for #5168 here -} html5 <- gets stHtml5 let titleSlide = slide && level < slideLevel let level' = if level <= slideLevel && slideVariant == SlidySlides then 1 -- see #3566 else level header' <- if ils == [Str "\0"] -- marker for hrule then return mempty else blockToHtml opts (Header level' hattr ils) let isSec (Div (_,"section":_,_) _) = True isSec (Div _ zs) = any isSec zs isSec _ = False let isPause (Para [Str ".",Space,Str ".",Space,Str "."]) = True isPause _ = False let fragmentClass = case slideVariant of RevealJsSlides -> "fragment" _ -> "incremental" let inDiv' zs = RawBlock (Format "html") ("

fragmentClass <> "\">") : (zs ++ [RawBlock (Format "html") "

"]) let breakOnPauses zs = case splitBy isPause zs of [] -> [] y:ys -> y ++ concatMap inDiv' ys let (titleBlocks, innerSecs) = if titleSlide -- title slides have no content of their own then let (as, bs) = break isSec xs in (breakOnPauses as, bs) else ([], breakOnPauses xs) let secttag = if html5 then H5.section else H.div titleContents <- blockListToHtml opts titleBlocks inSection <- gets stInSection innerContents <- do modify $ \st -> st{ stInSection = True } res <- blockListToHtml opts innerSecs modify $ \st -> st{ stInSection = inSection } return res let classes' = ordNub $ ["title-slide" | titleSlide] ++ ["slide" | slide] ++ ["section" | (slide || writerSectionDivs opts) && not html5 ] ++ ["level" <> tshow level | slide || writerSectionDivs opts ] <> dclasses let attr = (ident, classes', dkvs) if titleSlide then do t <- addAttrs opts attr $ secttag $ nl opts <> header' <> nl opts <> titleContents <> nl opts -- ensure 2D nesting for revealjs, but only for one level; -- revealjs doesn't like more than one level of nesting return $ if slideVariant == RevealJsSlides && not inSection && not (null innerSecs) then H5.section (nl opts <> t <> nl opts <> innerContents) else t <> nl opts <> if null innerSecs then mempty else innerContents <> nl opts else if writerSectionDivs opts || slide || (hident /= ident && not (T.null hident || T.null ident)) || (hclasses /= dclasses) || (hkvs /= dkvs) then addAttrs opts attr $ secttag $ nl opts <> header' <> nl opts <> if null innerSecs then mempty else innerContents <> nl opts else do let attr' = (ident, classes' \\ hclasses, dkvs \\ hkvs) t <- addAttrs opts attr' header' return $ t <> if null innerSecs then mempty else nl opts <> innerContents blockToHtmlInner opts (Div attr@(ident, classes, kvs') bs) = do html5 <- gets stHtml5 slideVariant <- gets stSlideVariant let isCslBibBody = ident == "refs" || "csl-bib-body" `elem` classes when isCslBibBody $ modify $ \st -> st{ stCsl = True , stCslEntrySpacing = lookup "entry-spacing" kvs' >>= safeRead } let isCslBibEntry = "csl-entry" `elem` classes let kvs = [(k,v) | (k,v) <- kvs' , k /= "width" || "column" `notElem` classes] ++ [("style", "width:" <> w <> ";") | "column" `elem` classes , ("width", w) <- kvs'] ++ [("role", "doc-bibliography") | isCslBibBody && html5] ++ [("role", "doc-biblioentry") | isCslBibEntry && html5] let speakerNotes = "notes" `elem` classes -- we don't want incremental output inside speaker notes, see #1394 let opts' = if | speakerNotes -> opts{ writerIncremental = False } | "incremental" `elem` classes -> opts{ writerIncremental = True } | "nonincremental" `elem` classes -> opts{ writerIncremental = False } | otherwise -> opts -- we remove "incremental" and "nonincremental" if we're in a -- slide presentaiton format. classes' = case slideVariant of NoSlides -> classes _ -> filter (\k -> k /= "incremental" && k /= "nonincremental") classes let paraToPlain (Para ils) = Plain ils paraToPlain x = x let bs' = if "csl-entry" `elem` classes' then walk paraToPlain bs else bs contents <- if "columns" `elem` classes' then -- we don't use blockListToHtml because it inserts -- a newline between the column divs, which throws -- off widths! see #4028 mconcat <$> mapM (blockToHtml opts) bs' else blockListToHtml opts' bs' let contents' = nl opts >> contents >> nl opts let (divtag, classes'') = if html5 && "section" `elem` classes' then (H5.section, filter (/= "section") classes') else (H.div, classes') if speakerNotes then case slideVariant of RevealJsSlides -> addAttrs opts' attr $ H5.aside contents' DZSlides -> do t <- addAttrs opts' attr $ H5.div contents' return $ t ! H5.customAttribute "role" "note" NoSlides -> addAttrs opts' attr $ H.div contents' _ -> return mempty else addAttrs opts (ident, classes'', kvs) $ divtag contents' blockToHtmlInner opts (RawBlock f str) = do ishtml <- isRawHtml f if ishtml then return $ preEscapedText str else if (f == Format "latex" || f == Format "tex") && allowsMathEnvironments (writerHTMLMathMethod opts) && isMathEnvironment str then blockToHtml opts $ Plain [Math DisplayMath str] else do report $ BlockNotRendered (RawBlock f str) return mempty blockToHtmlInner _ HorizontalRule = do html5 <- gets stHtml5 return $ if html5 then H5.hr else H.hr blockToHtmlInner opts (CodeBlock (id',classes,keyvals) rawCode) = do id'' <- if T.null id' then do modify $ \st -> st{ stCodeBlockNum = stCodeBlockNum st + 1 } codeblocknum <- gets stCodeBlockNum return (writerIdentifierPrefix opts <> "cb" <> tshow codeblocknum) else return (writerIdentifierPrefix opts <> id') let tolhs = isEnabled Ext_literate_haskell opts && any (\c -> T.toLower c == "haskell") classes && any (\c -> T.toLower c == "literate") classes classes' = if tolhs then map (\c -> if T.toLower c == "haskell" then "literatehaskell" else c) classes else classes adjCode = if tolhs then T.unlines . map ("> " <>) . T.lines $ rawCode else rawCode hlCode = if isJust (writerHighlightStyle opts) then highlight (writerSyntaxMap opts) formatHtmlBlock (id'',classes',keyvals) adjCode else Left "" case hlCode of Left msg -> do unless (T.null msg) $ report $ CouldNotHighlight msg addAttrs opts (id',classes,keyvals) $ H.pre $ H.code $ toHtml adjCode Right h -> modify (\st -> st{ stHighlighting = True }) >> -- we set writerIdentifierPrefix to "" since id'' already -- includes it: addAttrs opts{writerIdentifierPrefix = ""} (id'',[],keyvals) h blockToHtmlInner opts (BlockQuote blocks) = do -- in S5, treat list in blockquote specially -- if default is incremental, make it nonincremental; -- otherwise incremental slideVariant <- gets stSlideVariant if slideVariant /= NoSlides then let inc = not (writerIncremental opts) in case blocks of [BulletList lst] -> blockToHtml (opts {writerIncremental = inc}) (BulletList lst) [OrderedList attribs lst] -> blockToHtml (opts {writerIncremental = inc}) (OrderedList attribs lst) [DefinitionList lst] -> blockToHtml (opts {writerIncremental = inc}) (DefinitionList lst) _ -> do contents <- blockListToHtml opts blocks return $ H.blockquote $ nl opts >> contents >> nl opts else do contents <- blockListToHtml opts blocks return $ H.blockquote $ nl opts >> contents >> nl opts blockToHtmlInner opts (Header level (ident,classes,kvs) lst) = do contents <- inlineListToHtml opts lst let secnum = fromMaybe mempty $ lookup "number" kvs let contents' = if writerNumberSections opts && not (T.null secnum) && "unnumbered" `notElem` classes then (H.span ! A.class_ "header-section-number" $ toHtml secnum) >> strToHtml " " >> contents else contents html5 <- gets stHtml5 let kvs' = if html5 then kvs else [ (k, v) | (k, v) <- kvs , k `elem` (["lang", "dir", "title", "style" , "align"] ++ intrinsicEventsHTML4)] addAttrs opts (ident,classes,kvs') $ case level of 1 -> H.h1 contents' 2 -> H.h2 contents' 3 -> H.h3 contents' 4 -> H.h4 contents' 5 -> H.h5 contents' 6 -> H.h6 contents' _ -> H.p ! A.class_ "heading" $ contents' blockToHtmlInner opts (BulletList lst) = do contents <- mapM (listItemToHtml opts) lst let isTaskList = not (null lst) && all isTaskListItem lst (if isTaskList then (! A.class_ "task-list") else id) <$> unordList opts contents blockToHtmlInner opts (OrderedList (startnum, numstyle, _) lst) = do contents <- mapM (listItemToHtml opts) lst html5 <- gets stHtml5 let numstyle' = case numstyle of Example -> "decimal" _ -> camelCaseToHyphenated $ tshow numstyle let attribs = [A.start $ toValue startnum | startnum /= 1] ++ [A.class_ "example" | numstyle == Example] ++ (if numstyle /= DefaultStyle then if html5 then [A.type_ $ case numstyle of Decimal -> "1" LowerAlpha -> "a" UpperAlpha -> "A" LowerRoman -> "i" UpperRoman -> "I" _ -> "1"] else [A.style $ toValue $ "list-style-type: " <> numstyle'] else []) l <- ordList opts contents return $ foldl' (!) l attribs blockToHtmlInner opts (DefinitionList lst) = do contents <- mapM (\(term, defs) -> do term' <- liftM H.dt $ inlineListToHtml opts term defs' <- mapM (liftM (\x -> H.dd (x >> nl opts)) . blockListToHtml opts) defs return $ mconcat $ nl opts : term' : nl opts : intersperse (nl opts) defs') lst defList opts contents blockToHtmlInner opts (Table attr caption colspecs thead tbody tfoot) = tableToHtml opts (Ann.toTable attr caption colspecs thead tbody tfoot) -- | Convert Pandoc block element to HTML. All the legwork is done by -- 'blockToHtmlInner', this just takes care of emitting the notes after -- the block if necessary. blockToHtml :: PandocMonad m => WriterOptions -> Block -> StateT WriterState m Html blockToHtml opts block = do -- Ignore inserted section divs -- they are not blocks as they came from -- the document itself (at least not when coming from markdown) let isSection = case block of Div (_, classes, _) _ | "section" `elem` classes -> True _ -> False let increaseLevel = not isSection when increaseLevel $ modify (\st -> st{ stBlockLevel = stBlockLevel st + 1 }) doc <- blockToHtmlInner opts block st <- get let emitNotes = (writerReferenceLocation opts == EndOfBlock && stBlockLevel st == 1) || (writerReferenceLocation opts == EndOfSection && isSection) res <- if emitNotes then do notes <- if null (stNotes st) then return mempty else footnoteSection opts (writerReferenceLocation opts) (stEmittedNotes st + 1) (reverse (stNotes st)) modify (\st' -> st'{ stNotes = mempty, stEmittedNotes = stEmittedNotes st' + length (stNotes st') }) return (doc <> notes) else return doc when increaseLevel $ modify (\st' -> st'{ stBlockLevel = stBlockLevel st' - 1 }) return res tableToHtml :: PandocMonad m => WriterOptions -> Ann.Table -> StateT WriterState m Html tableToHtml opts (Ann.Table attr caption colspecs thead tbodies tfoot) = do captionDoc <- case caption of Caption _ [] -> return mempty Caption _ longCapt -> do cs <- blockListToHtml opts longCapt return $ do H.caption cs nl opts coltags <- colSpecListToHtml opts colspecs head' <- tableHeadToHtml opts thead bodies <- intersperse (nl opts) <$> mapM (tableBodyToHtml opts) tbodies foot' <- tableFootToHtml opts tfoot let (ident,classes,kvs) = attr -- When widths of columns are < 100%, we need to set width for the whole -- table, or some browsers give us skinny columns with lots of space -- between: let colWidth = \case ColWidth d -> d ColWidthDefault -> 0 let totalWidth = sum . map (colWidth . snd) $ colspecs let attr' = case lookup "style" kvs of Nothing | totalWidth < 1 && totalWidth > 0 -> (ident,classes, ("style","width:" <> T.pack (show (round (totalWidth * 100) :: Int)) <> "%;"):kvs) _ -> attr addAttrs opts attr' $ H.table $ do nl opts captionDoc coltags head' mconcat bodies foot' nl opts tableBodyToHtml :: PandocMonad m => WriterOptions -> Ann.TableBody -> StateT WriterState m Html tableBodyToHtml opts (Ann.TableBody attr _rowHeadCols inthead rows) = addAttrs opts attr . H.tbody =<< do intermediateHead <- if null inthead then return mempty else headerRowsToHtml opts Thead inthead bodyRows <- bodyRowsToHtml opts rows return $ intermediateHead <> bodyRows tableHeadToHtml :: PandocMonad m => WriterOptions -> Ann.TableHead -> StateT WriterState m Html tableHeadToHtml opts (Ann.TableHead attr rows) = tablePartToHtml opts Thead attr rows tableFootToHtml :: PandocMonad m => WriterOptions -> Ann.TableFoot -> StateT WriterState m Html tableFootToHtml opts (Ann.TableFoot attr rows) = tablePartToHtml opts Tfoot attr rows tablePartToHtml :: PandocMonad m => WriterOptions -> TablePart -> Attr -> [Ann.HeaderRow] -> StateT WriterState m Html tablePartToHtml opts tblpart attr rows = if null rows || all isEmptyRow rows then return mempty else do let tag' = case tblpart of Thead -> H.thead Tfoot -> H.tfoot Tbody -> H.tbody -- this would be unexpected contents <- headerRowsToHtml opts tblpart rows tablePartElement <- addAttrs opts attr $ tag' contents return $ do tablePartElement nl opts where isEmptyRow (Ann.HeaderRow _attr _rownum cells) = all isEmptyCell cells isEmptyCell (Ann.Cell _colspecs _colnum cell) = cell == Cell nullAttr AlignDefault (RowSpan 1) (ColSpan 1) [] -- | The part of a table; header, footer, or body. data TablePart = Thead | Tfoot | Tbody deriving (Eq) data CellType = HeaderCell | BodyCell data TableRow = TableRow TablePart Attr Ann.RowNumber Ann.RowHead Ann.RowBody headerRowsToHtml :: PandocMonad m => WriterOptions -> TablePart -> [Ann.HeaderRow] -> StateT WriterState m Html headerRowsToHtml opts tablepart = rowListToHtml opts . map toTableRow where toTableRow (Ann.HeaderRow attr rownum rowbody) = TableRow tablepart attr rownum [] rowbody bodyRowsToHtml :: PandocMonad m => WriterOptions -> [Ann.BodyRow] -> StateT WriterState m Html bodyRowsToHtml opts = rowListToHtml opts . zipWith toTableRow [1..] where toTableRow rownum (Ann.BodyRow attr _rownum rowhead rowbody) = TableRow Tbody attr rownum rowhead rowbody rowListToHtml :: PandocMonad m => WriterOptions -> [TableRow] -> StateT WriterState m Html rowListToHtml opts rows = (\x -> nl opts *> mconcat x) <$> mapM (tableRowToHtml opts) rows colSpecListToHtml :: PandocMonad m => WriterOptions -> [ColSpec] -> StateT WriterState m Html colSpecListToHtml opts colspecs = do html5 <- gets stHtml5 let hasDefaultWidth (_, ColWidthDefault) = True hasDefaultWidth _ = False let percent w = show (truncate (100*w) :: Integer) <> "%" let col :: ColWidth -> Html col cw = do H.col ! case cw of ColWidthDefault -> mempty ColWidth w -> if html5 then A.style (toValue $ "width: " <> percent w) else A.width (toValue $ percent w) nl opts return $ if all hasDefaultWidth colspecs then mempty else do H.colgroup $ do nl opts mapM_ (col . snd) colspecs nl opts tableRowToHtml :: PandocMonad m => WriterOptions -> TableRow -> StateT WriterState m Html tableRowToHtml opts (TableRow tblpart attr rownum rowhead rowbody) = do let rowclass = case rownum of Ann.RowNumber x | x `rem` 2 == 1 -> "odd" _ | tblpart /= Thead -> "even" _ -> "header" let attr' = case attr of (id', classes, rest) -> (id', rowclass:classes, rest) let celltype = case tblpart of Thead -> HeaderCell _ -> BodyCell headcells <- mapM (cellToHtml opts HeaderCell) rowhead bodycells <- mapM (cellToHtml opts celltype) rowbody rowHtml <- addAttrs opts attr' $ H.tr $ do nl opts mconcat headcells mconcat bodycells return $ do rowHtml nl opts alignmentToString :: Alignment -> Maybe Text alignmentToString = \case AlignLeft -> Just "left" AlignRight -> Just "right" AlignCenter -> Just "center" AlignDefault -> Nothing colspanAttrib :: ColSpan -> Attribute colspanAttrib = \case ColSpan 1 -> mempty ColSpan n -> A.colspan (toValue n) rowspanAttrib :: RowSpan -> Attribute rowspanAttrib = \case RowSpan 1 -> mempty RowSpan n -> A.rowspan (toValue n) cellToHtml :: PandocMonad m => WriterOptions -> CellType -> Ann.Cell -> StateT WriterState m Html cellToHtml opts celltype (Ann.Cell (colspec :| _) _colNum cell) = let align = fst colspec in tableCellToHtml opts celltype align cell tableCellToHtml :: PandocMonad m => WriterOptions -> CellType -> Alignment -> Cell -> StateT WriterState m Html tableCellToHtml opts ctype colAlign (Cell attr align rowspan colspan item) = do contents <- blockListToHtml opts item html5 <- gets stHtml5 let tag' = case ctype of BodyCell -> H.td HeaderCell -> H.th let align' = case align of AlignDefault -> colAlign _ -> align let alignAttribs = case alignmentToString align' of Nothing -> mempty Just alignStr -> if html5 then A.style (toValue $ "text-align: " <> alignStr <> ";") else A.align (toValue alignStr) otherAttribs <- attrsToHtml opts attr let attribs = mconcat $ alignAttribs : colspanAttrib colspan : rowspanAttrib rowspan : otherAttribs return $ do tag' ! attribs $ contents nl opts toListItems :: WriterOptions -> [Html] -> [Html] toListItems opts items = map (toListItem opts) items ++ [nl opts] toListItem :: WriterOptions -> Html -> Html toListItem opts item = nl opts *> H.li item blockListToHtml :: PandocMonad m => WriterOptions -> [Block] -> StateT WriterState m Html blockListToHtml opts lst = mconcat . intersperse (nl opts) . filter nonempty <$> mapM (blockToHtml opts) lst where nonempty (Empty _) = False nonempty _ = True -- | Convert list of Pandoc inline elements to HTML. inlineListToHtml :: PandocMonad m => WriterOptions -> [Inline] -> StateT WriterState m Html inlineListToHtml opts lst = mconcat <$> mapM (inlineToHtml opts) lst -- | Annotates a MathML expression with the tex source annotateMML :: XML.Element -> Text -> XML.Element annotateMML e tex = math (unode "semantics" [cs, unode "annotation" (annotAttrs, T.unpack tex)]) where cs = case elChildren e of [] -> unode "mrow" () [x] -> x xs -> unode "mrow" xs math childs = XML.Element q as [XML.Elem childs] l where (XML.Element q as _ l) = e annotAttrs = [XML.Attr (unqual "encoding") "application/x-tex"] -- | Convert Pandoc inline element to HTML. inlineToHtml :: PandocMonad m => WriterOptions -> Inline -> StateT WriterState m Html inlineToHtml opts inline = do html5 <- gets stHtml5 case inline of (Str str) -> return $ strToHtml str Space -> return $ strToHtml " " SoftBreak -> return $ case writerWrapText opts of WrapNone -> preEscapedText " " WrapAuto -> preEscapedText " " WrapPreserve -> preEscapedText "\n" LineBreak -> return $ do if html5 then H5.br else H.br strToHtml "\n" (Span ("",[cls],[]) ils) | cls == "csl-block" || cls == "csl-left-margin" || cls == "csl-right-inline" || cls == "csl-indent" -> inlineListToHtml opts ils >>= inDiv cls (Span (id',classes,kvs) ils) -> let spanLikeTag = case classes of (c:_) -> do guard (c `Set.member` htmlSpanLikeElements) pure $ customParent (textTag c) _ -> Nothing in case spanLikeTag of Just tag -> do h <- inlineListToHtml opts ils addAttrs opts (id',tail classes',kvs') $ tag h Nothing -> do h <- inlineListToHtml opts ils addAttrs opts (id',classes',kvs') (H.span h) where styles = ["font-style:normal;" | "csl-no-emph" `elem` classes] ++ ["font-weight:normal;" | "csl-no-strong" `elem` classes] ++ ["font-variant:normal;" | "csl-no-smallcaps" `elem` classes] kvs' = if null styles then kvs else ("style", T.concat styles) : kvs classes' = [ c | c <- classes , c `notElem` [ "csl-no-emph" , "csl-no-strong" , "csl-no-smallcaps" ] ] (Emph lst) -> H.em <$> inlineListToHtml opts lst (Underline lst) -> H.u <$> inlineListToHtml opts lst (Strong lst) -> H.strong <$> inlineListToHtml opts lst (Code attr@(ids,cs,kvs) str) -> case hlCode of Left msg -> do unless (T.null msg) $ report $ CouldNotHighlight msg addAttrs opts (ids,cs',kvs) $ fromMaybe H.code sampOrVar $ strToHtml str Right h -> do modify $ \st -> st{ stHighlighting = True } addAttrs opts (ids,[],kvs) $ fromMaybe id sampOrVar h where hlCode = if isJust (writerHighlightStyle opts) then highlight (writerSyntaxMap opts) formatHtmlInline attr str else Left "" (sampOrVar,cs') | "sample" `elem` cs = (Just H.samp,"sample" `delete` cs) | "variable" `elem` cs = (Just H.var,"variable" `delete` cs) | otherwise = (Nothing,cs) (Strikeout lst) -> H.del <$> inlineListToHtml opts lst (SmallCaps lst) -> (H.span ! A.class_ "smallcaps") <$> inlineListToHtml opts lst (Superscript lst) -> H.sup <$> inlineListToHtml opts lst (Subscript lst) -> H.sub <$> inlineListToHtml opts lst (Quoted quoteType lst) -> let (leftQuote, rightQuote) = case quoteType of SingleQuote -> (strToHtml "‘", strToHtml "’") DoubleQuote -> (strToHtml "“", strToHtml "”") in if writerHtmlQTags opts then do modify $ \st -> st{ stQuotes = True } let (maybeAttr, lst') = case lst of [Span attr@(_, _, kvs) cs] | any ((=="cite") . fst) kvs -> (Just attr, cs) cs -> (Nothing, cs) let addAttrsMb = maybe return (addAttrs opts) inlineListToHtml opts lst' >>= addAttrsMb maybeAttr . H.q else (\x -> leftQuote >> x >> rightQuote) `fmap` inlineListToHtml opts lst (Math t str) -> do modify (\st -> st {stMath = True}) let mathClass = toValue $ ("math " :: Text) <> if t == InlineMath then "inline" else "display" case writerHTMLMathMethod opts of WebTeX url -> do let imtag = if html5 then H5.img else H.img let s = case t of InlineMath -> "\\textstyle " DisplayMath -> "\\displaystyle " return $ imtag ! A.style "vertical-align:middle" ! A.src (toValue . (url <>) . urlEncode $ s <> str) ! A.alt (toValue str) ! A.title (toValue str) ! A.class_ mathClass GladTeX -> return $ customParent (textTag "eq") ! customAttribute "env" (toValue $ if t == InlineMath then ("math" :: Text) else "displaymath") $ strToHtml str MathML -> do let conf = useShortEmptyTags (const False) defaultConfigPP res <- lift $ convertMath writeMathML t str case res of Right r -> return $ preEscapedString $ ppcElement conf (annotateMML r str) Left il -> (H.span ! A.class_ mathClass) <$> inlineToHtml opts il MathJax _ -> return $ H.span ! A.class_ mathClass $ toHtml $ case t of InlineMath -> "\$" <> str <> "\$" DisplayMath -> "\\[" <> str <> "\\]" KaTeX _ -> return $ H.span ! A.class_ mathClass $ toHtml $ case t of InlineMath -> str DisplayMath -> str PlainMath -> do x <- lift (texMathToInlines t str) >>= inlineListToHtml opts return $ H.span ! A.class_ mathClass $ x (RawInline f str) -> do ishtml <- isRawHtml f if ishtml then return $ preEscapedText str else do let istex = f == Format "latex" || f == Format "tex" let mm = writerHTMLMathMethod opts case istex of True | allowsMathEnvironments mm && isMathEnvironment str -> inlineToHtml opts $ Math DisplayMath str | allowsRef mm && isRef str -> inlineToHtml opts $ Math InlineMath str _ -> do report $ InlineNotRendered inline return mempty (Link attr txt (s,_)) | "mailto:" `T.isPrefixOf` s -> do linkText <- inlineListToHtml opts txt obfuscateLink opts attr linkText s (Link (ident,classes,kvs) txt (s,tit)) -> do linkText <- inlineListToHtml opts txt slideVariant <- gets stSlideVariant let s' = case T.uncons s of Just ('#',xs) -> let prefix = if slideVariant == RevealJsSlides then "/" else writerIdentifierPrefix opts in "#" <> prefix <> xs _ -> s let link = H.a ! A.href (toValue s') $ linkText link' <- addAttrs opts (ident, classes, kvs) link return $ if T.null tit then link' else link' ! A.title (toValue tit) (Image attr@(_, _, attrList) txt (s, tit)) -> do let alternate = stringify txt slideVariant <- gets stSlideVariant let isReveal = slideVariant == RevealJsSlides attrs <- imgAttrsToHtml opts attr let attributes = -- reveal.js uses data-src for lazy loading (if isReveal then customAttribute "data-src" $ toValue s else A.src $ toValue s) : [A.title $ toValue tit | not (T.null tit)] ++ attrs imageTag = (if html5 then H5.img else H.img , [A.alt $ toValue alternate | not (null txt) && isNothing (lookup "alt" attrList)] ) mediaTag tg fallbackTxt = let linkTxt = if null txt then fallbackTxt else alternate in (tg $ H.a ! A.href (toValue s) $ toHtml linkTxt , [A5.controls ""] ) normSrc = maybe (T.unpack s) uriPath (parseURIReference $ T.unpack s) (tag, specAttrs) = case mediaCategory normSrc of Just "image" -> imageTag Just "video" -> mediaTag H5.video "Video" Just "audio" -> mediaTag H5.audio "Audio" Just _ -> (H5.embed, []) _ -> imageTag return $ foldl' (!) tag $ attributes ++ specAttrs -- note: null title included, as in Markdown.pl (Note contents) -> do notes <- gets stNotes emittedNotes <- gets stEmittedNotes let number = emittedNotes + length notes + 1 let ref = tshow number htmlContents <- blockListToNote opts ref contents epubVersion <- gets stEPUBVersion -- push contents onto front of notes modify $ \st -> st {stNotes = htmlContents:notes} slideVariant <- gets stSlideVariant let revealSlash = T.pack ['/' | slideVariant == RevealJsSlides] let link = H.a ! A.href (toValue $ "#" <> revealSlash <> writerIdentifierPrefix opts <> "fn" <> ref) ! A.class_ "footnote-ref" ! prefixedId opts ("fnref" <> ref) $ (if isJust epubVersion then id else H.sup) $ toHtml ref return $ case epubVersion of Just EPUB3 -> link ! customAttribute "epub:type" "noteref" _ | html5 -> link ! H5.customAttribute "role" "doc-noteref" _ -> link (Cite cits il)-> do contents <- inlineListToHtml opts (walk addRoleToLink il) let citationIds = T.unwords $ map citationId cits let result = H.span ! A.class_ "citation" $ contents return $ if html5 then result ! customAttribute "data-cites" (toValue citationIds) else result addRoleToLink :: Inline -> Inline addRoleToLink (Link (id',classes,kvs) ils (src,tit)) = Link (id',classes,("role","doc-biblioref"):kvs) ils (src,tit) addRoleToLink x = x blockListToNote :: PandocMonad m => WriterOptions -> Text -> [Block] -> StateT WriterState m Html blockListToNote opts ref blocks = do html5 <- gets stHtml5 -- If last block is Para or Plain, include the backlink at the end of -- that block. Otherwise, insert a new Plain block with the backlink. let kvs = [("role","doc-backlink") | html5] let backlink = [Link ("",["footnote-back"],kvs) [Str "↩"] ("#" <> "fnref" <> ref,"")] let blocks' = if null blocks then [] else let lastBlock = last blocks otherBlocks = init blocks in case lastBlock of Para [Image _ _ (_,tit)] | "fig:" `T.isPrefixOf` tit -> otherBlocks ++ [lastBlock, Plain backlink] Para lst -> otherBlocks ++ [Para (lst ++ backlink)] Plain lst -> otherBlocks ++ [Plain (lst ++ backlink)] _ -> otherBlocks ++ [lastBlock, Plain backlink] contents <- blockListToHtml opts blocks' let noteItem = H.li ! prefixedId opts ("fn" <> ref) $ contents epubVersion <- gets stEPUBVersion let noteItem' = case epubVersion of Just EPUB3 -> noteItem ! customAttribute "epub:type" "footnote" _ | html5 -> noteItem ! customAttribute "role" "doc-endnote" _ -> noteItem return $ nl opts >> noteItem' inDiv :: PandocMonad m=> Text -> Html -> StateT WriterState m Html inDiv cls x = do html5 <- gets stHtml5 return $ (if html5 then H5.div else H.div) x ! A.class_ (toValue cls) isRef :: Text -> Bool isRef t = "\\ref{" `T.isPrefixOf` t || "\\eqref{" `T.isPrefixOf` t isMathEnvironment :: Text -> Bool isMathEnvironment s = "\\begin{" `T.isPrefixOf` s && envName `elem` mathmlenvs where envName = T.takeWhile (/= '}') (T.drop 7 s) mathmlenvs = [ "align" , "align*" , "alignat" , "alignat*" , "aligned" , "alignedat" , "array" , "Bmatrix" , "bmatrix" , "cases" , "CD" , "eqnarray" , "eqnarray*" , "equation" , "equation*" , "gather" , "gather*" , "gathered" , "matrix" , "multline" , "multline*" , "pmatrix" , "smallmatrix" , "split" , "subarray" , "Vmatrix" , "vmatrix" ] allowsMathEnvironments :: HTMLMathMethod -> Bool allowsMathEnvironments (MathJax _) = True allowsMathEnvironments (KaTeX _) = True allowsMathEnvironments MathML = True allowsMathEnvironments (WebTeX _) = True allowsMathEnvironments _ = False allowsRef :: HTMLMathMethod -> Bool allowsRef (MathJax _) = True allowsRef _ = False -- | List of intrinsic event attributes allowed on all elements in HTML4. intrinsicEventsHTML4 :: [Text] intrinsicEventsHTML4 = [ "onclick", "ondblclick", "onmousedown", "onmouseup", "onmouseover" , "onmouseout", "onmouseout", "onkeypress", "onkeydown", "onkeyup"] isRawHtml :: PandocMonad m => Format -> StateT WriterState m Bool isRawHtml f = do html5 <- gets stHtml5 return $ f == Format "html" || ((html5 && f == Format "html5") || f == Format "html4")