diff options
Diffstat (limited to 'src/Text/Pandoc/Writers/ConTeXt.hs')
-rw-r--r-- | src/Text/Pandoc/Writers/ConTeXt.hs | 302 |
1 files changed, 302 insertions, 0 deletions
diff --git a/src/Text/Pandoc/Writers/ConTeXt.hs b/src/Text/Pandoc/Writers/ConTeXt.hs new file mode 100644 index 000000000..014751968 --- /dev/null +++ b/src/Text/Pandoc/Writers/ConTeXt.hs @@ -0,0 +1,302 @@ +{- +Copyright (C) 2007-8 John MacFarlane <jgm@berkeley.edu> + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : Text.Pandoc.Writers.ConTeXt + Copyright : Copyright (C) 2007-8 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane <jgm@berkeley.edu> + Stability : alpha + Portability : portable + +Conversion of 'Pandoc' format into ConTeXt. +-} +module Text.Pandoc.Writers.ConTeXt ( writeConTeXt ) where +import Text.Pandoc.Definition +import Text.Pandoc.Shared +import Text.Printf ( printf ) +import Data.List ( isSuffixOf, intercalate ) +import Control.Monad.State +import Text.PrettyPrint.HughesPJ hiding ( Str ) + +data WriterState = + WriterState { stNextRef :: Int -- number of next URL reference + , stOrderedListLevel :: Int -- level of ordered list + , stOptions :: WriterOptions -- writer options + } + +orderedListStyles :: [[Char]] +orderedListStyles = cycle ["[n]","[a]", "[r]", "[g]"] + +-- | Convert Pandoc to ConTeXt. +writeConTeXt :: WriterOptions -> Pandoc -> String +writeConTeXt options document = + let defaultWriterState = WriterState { stNextRef = 1 + , stOrderedListLevel = 0 + , stOptions = options + } + in render $ + evalState (pandocToConTeXt options document) defaultWriterState + +pandocToConTeXt :: WriterOptions -> Pandoc -> State WriterState Doc +pandocToConTeXt options (Pandoc meta blocks) = do + main <- blockListToConTeXt blocks + let before = if null (writerIncludeBefore options) + then empty + else text $ writerIncludeBefore options + let after = if null (writerIncludeAfter options) + then empty + else text $ writerIncludeAfter options + let body = before $$ main $$ after + head' <- if writerStandalone options + then contextHeader options meta + else return empty + let toc = if writerTableOfContents options + then text "\\placecontent\n" + else empty + let foot = if writerStandalone options + then text "\\stoptext\n" + else empty + return $ head' $$ toc $$ body $$ foot + +-- | Insert bibliographic information into ConTeXt header. +contextHeader :: WriterOptions -- ^ Options, including ConTeXt header + -> Meta -- ^ Meta with bibliographic information + -> State WriterState Doc +contextHeader options (Meta title authors date) = do + titletext <- if null title + then return empty + else inlineListToConTeXt title + let authorstext = if null authors + then "" + else if length authors == 1 + then stringToConTeXt $ head authors + else stringToConTeXt $ (intercalate ", " $ + init authors) ++ " & " ++ last authors + let datetext = if date == "" + then "" + else stringToConTeXt date + let titleblock = text "\\doctitle{" <> titletext <> char '}' $$ + text ("\\author{" ++ authorstext ++ "}") $$ + text ("\\date{" ++ datetext ++ "}") + let header = text $ writerHeader options + return $ header $$ titleblock $$ text "\\starttext\n\\maketitle\n" + +-- escape things as needed for ConTeXt + +escapeCharForConTeXt :: Char -> String +escapeCharForConTeXt ch = + case ch of + '{' -> "\\letteropenbrace{}" + '}' -> "\\letterclosebrace{}" + '\\' -> "\\letterbackslash{}" + '$' -> "\\$" + '|' -> "\\letterbar{}" + '^' -> "\\letterhat{}" + '%' -> "\\%" + '~' -> "\\lettertilde{}" + '&' -> "\\&" + '#' -> "\\#" + '<' -> "\\letterless{}" + '>' -> "\\lettermore{}" + '_' -> "\\letterunderscore{}" + '\160' -> "~" + x -> [x] + +-- | Escape string for ConTeXt +stringToConTeXt :: String -> String +stringToConTeXt = concatMap escapeCharForConTeXt + +-- | Convert Pandoc block element to ConTeXt. +blockToConTeXt :: Block + -> State WriterState BlockWrapper +blockToConTeXt Null = return $ Reg empty +blockToConTeXt (Plain lst) = do + st <- get + let options = stOptions st + contents <- wrapTeXIfNeeded options False inlineListToConTeXt lst + return $ Reg contents +blockToConTeXt (Para lst) = do + st <- get + let options = stOptions st + contents <- wrapTeXIfNeeded options False inlineListToConTeXt lst + return $ Pad contents +blockToConTeXt (BlockQuote lst) = do + contents <- blockListToConTeXt lst + return $ Pad $ text "\\startblockquote" $$ contents $$ text "\\stopblockquote" +blockToConTeXt (CodeBlock _ str) = + return $ Reg $ text $ "\\starttyping\n" ++ str ++ "\n\\stoptyping\n" + -- \n because \stoptyping can't have anything after it, inc. } +blockToConTeXt (RawHtml _) = return $ Reg empty +blockToConTeXt (BulletList lst) = do + contents <- mapM listItemToConTeXt lst + return $ Pad $ text "\\startitemize" $$ vcat contents $$ text "\\stopitemize" +blockToConTeXt (OrderedList (start, style', delim) lst) = do + st <- get + let level = stOrderedListLevel st + put $ st {stOrderedListLevel = level + 1} + contents <- mapM listItemToConTeXt lst + put $ st {stOrderedListLevel = level} + let start' = if start == 1 then "" else "start=" ++ show start + let delim' = case delim of + DefaultDelim -> "" + Period -> "stopper=." + OneParen -> "stopper=)" + TwoParens -> "left=(,stopper=)" + let width = maximum $ map length $ take (length contents) + (orderedListMarkers (start, style', delim)) + let width' = (toEnum width + 1) / 2 + let width'' = if width' > (1.5 :: Double) + then "width=" ++ show width' ++ "em" + else "" + let specs2Items = filter (not . null) [start', delim', width''] + let specs2 = if null specs2Items + then "" + else "[" ++ intercalate "," specs2Items ++ "]" + let style'' = case style' of + DefaultStyle -> orderedListStyles !! level + Decimal -> "[n]" + LowerRoman -> "[r]" + UpperRoman -> "[R]" + LowerAlpha -> "[a]" + UpperAlpha -> "[A]" + let specs = style'' ++ specs2 + return $ Pad $ text ("\\startitemize" ++ specs) $$ vcat contents $$ + text "\\stopitemize" +blockToConTeXt (DefinitionList lst) = + mapM defListItemToConTeXt lst >>= return . Pad . wrappedBlocksToDoc +blockToConTeXt HorizontalRule = return $ Pad $ text "\\thinrule" +blockToConTeXt (Header level lst) = do + contents <- inlineListToConTeXt lst + st <- get + let opts = stOptions st + let base = if writerNumberSections opts then "section" else "subject" + return $ Pad $ if level >= 1 && level <= 5 + then char '\\' <> text (concat (replicate (level - 1) "sub")) <> + text base <> char '{' <> contents <> char '}' + else contents +blockToConTeXt (Table caption aligns widths heads rows) = do + let colWidths = map printDecimal widths + let colDescriptor colWidth alignment = (case alignment of + AlignLeft -> 'l' + AlignRight -> 'r' + AlignCenter -> 'c' + AlignDefault -> 'l'): + "p(" ++ colWidth ++ "\\textwidth)|" + let colDescriptors = "|" ++ (concat $ + zipWith colDescriptor colWidths aligns) + headers <- tableRowToConTeXt heads + captionText <- inlineListToConTeXt caption + let captionText' = if null caption then text "none" else captionText + rows' <- mapM tableRowToConTeXt rows + return $ Pad $ text "\\placetable[here]{" <> captionText' <> char '}' $$ + text "\\starttable[" <> text colDescriptors <> char ']' $$ + text "\\HL" $$ headers $$ text "\\HL" $$ + vcat rows' $$ text "\\HL\n\\stoptable" + +printDecimal :: Double -> String +printDecimal = printf "%.2f" + +tableRowToConTeXt :: [[Block]] -> State WriterState Doc +tableRowToConTeXt cols = do + cols' <- mapM blockListToConTeXt cols + return $ (vcat (map (text "\\NC " <>) cols')) $$ + text "\\NC\\AR" + +listItemToConTeXt :: [Block] -> State WriterState Doc +listItemToConTeXt list = blockListToConTeXt list >>= + return . (text "\\item" $$) . (nest 2) + +defListItemToConTeXt :: ([Inline], [Block]) -> State WriterState BlockWrapper +defListItemToConTeXt (term, def) = do + term' <- inlineListToConTeXt term + def' <- blockListToConTeXt def + return $ Pad $ text "\\startdescr{" <> term' <> char '}' $$ def' $$ text "\\stopdescr" + +-- | Convert list of block elements to ConTeXt. +blockListToConTeXt :: [Block] -> State WriterState Doc +blockListToConTeXt lst = mapM blockToConTeXt lst >>= return . wrappedBlocksToDoc + +-- | Convert list of inline elements to ConTeXt. +inlineListToConTeXt :: [Inline] -- ^ Inlines to convert + -> State WriterState Doc +inlineListToConTeXt lst = mapM inlineToConTeXt lst >>= return . hcat + +-- | Convert inline element to ConTeXt +inlineToConTeXt :: Inline -- ^ Inline to convert + -> State WriterState Doc +inlineToConTeXt (Emph lst) = do + contents <- inlineListToConTeXt lst + return $ text "{\\em " <> contents <> char '}' +inlineToConTeXt (Strong lst) = do + contents <- inlineListToConTeXt lst + return $ text "{\\bf " <> contents <> char '}' +inlineToConTeXt (Strikeout lst) = do + contents <- inlineListToConTeXt lst + return $ text "\\overstrikes{" <> contents <> char '}' +inlineToConTeXt (Superscript lst) = do + contents <- inlineListToConTeXt lst + return $ text "\\high{" <> contents <> char '}' +inlineToConTeXt (Subscript lst) = do + contents <- inlineListToConTeXt lst + return $ text "\\low{" <> contents <> char '}' +inlineToConTeXt (SmallCaps lst) = do + contents <- inlineListToConTeXt lst + return $ text "{\\sc " <> contents <> char '}' +inlineToConTeXt (Code str) = return $ text $ "\\type{" ++ str ++ "}" +inlineToConTeXt (Quoted SingleQuote lst) = do + contents <- inlineListToConTeXt lst + return $ text "\\quote{" <> contents <> char '}' +inlineToConTeXt (Quoted DoubleQuote lst) = do + contents <- inlineListToConTeXt lst + return $ text "\\quotation{" <> contents <> char '}' +inlineToConTeXt (Cite _ lst) = inlineListToConTeXt lst +inlineToConTeXt Apostrophe = return $ char '\'' +inlineToConTeXt EmDash = return $ text "---" +inlineToConTeXt EnDash = return $ text "--" +inlineToConTeXt Ellipses = return $ text "\\ldots{}" +inlineToConTeXt (Str str) = return $ text $ stringToConTeXt str +inlineToConTeXt (Math InlineMath str) = return $ char '$' <> text str <> char '$' +inlineToConTeXt (Math DisplayMath str) = return $ text "\\startformula " <> text str <> text " \\stopformula" +inlineToConTeXt (TeX str) = return $ text str +inlineToConTeXt (HtmlInline _) = return empty +inlineToConTeXt (LineBreak) = return $ text "\\crlf\n" +inlineToConTeXt Space = return $ char ' ' +inlineToConTeXt (Link [Code str] (src, tit)) = -- since ConTeXt has its own + inlineToConTeXt (Link [Str str] (src, tit)) -- way of printing links... +inlineToConTeXt (Link txt (src, _)) = do + st <- get + let next = stNextRef st + put $ st {stNextRef = next + 1} + let ref = show next + label <- inlineListToConTeXt txt + return $ text "\\useURL[" <> text ref <> text "][" <> text src <> + text "][][" <> label <> text "]\\from[" <> text ref <> char ']' +inlineToConTeXt (Image alternate (src, tit)) = do + alt <- inlineListToConTeXt alternate + return $ text "\\placefigure\n[]\n[fig:" <> alt <> text "]\n{" <> + text tit <> text "}\n{\\externalfigure[" <> text src <> text "]}" +inlineToConTeXt (Note contents) = do + contents' <- blockListToConTeXt contents + let rawnote = stripTrailingNewlines $ render contents' + -- note: a \n before } is needed when note ends with a \stoptyping + let optNewline = "\\stoptyping" `isSuffixOf` rawnote + return $ text "\\footnote{" <> + text rawnote <> (if optNewline then char '\n' else empty) <> char '}' + |