module Text.BlogLiterately.Transform
(
Transform(..), runTransform, runTransforms
, wptexifyXF
, ghciXF
, imagesXF
, highlightXF
, standardTransforms
, centerImagesXF
, xformDoc
, whenA, fixLineEndings
) where
import Control.Arrow ( first, (>>>), arr
, Kleisli(..), runKleisli )
import qualified Control.Category as C ( Category, id )
import qualified Data.Traversable as T
import Data.Default ( def )
import qualified Data.Set as S
import Data.Bool.Extras ( whenA )
import Data.List ( isPrefixOf )
import Text.Blaze.Html.Renderer.String ( renderHtml )
import Text.Pandoc
import Text.Pandoc.Options
import Text.BlogLiterately.Ghci
import Text.BlogLiterately.Highlight
import Text.BlogLiterately.Image
import Text.BlogLiterately.LaTeX
import Text.BlogLiterately.Options
data Transform = Transform
{ getTransform :: BlogLiterately -> Kleisli IO Pandoc Pandoc
, xfCond :: BlogLiterately -> Bool
}
runTransform :: Transform -> BlogLiterately -> Kleisli IO Pandoc Pandoc
runTransform t bl = getTransform t bl `whenA` xfCond t bl
runTransforms :: [Transform] -> BlogLiterately -> Kleisli IO Pandoc Pandoc
runTransforms ts = foldr (>>>) (C.id) . T.traverse runTransform ts
wptexifyXF :: Transform
wptexifyXF = Transform (const (arr wpTeXify)) wplatex
ghciXF :: Transform
ghciXF = Transform (Kleisli . formatInlineGhci . file) ghci
imagesXF :: Transform
imagesXF = Transform (Kleisli . uploadAllImages) uploadImages
highlightXF :: Transform
highlightXF = Transform
(\bl -> arr (colourisePandoc (hsHighlight bl) (otherHighlight bl)))
(const True)
standardTransforms :: [Transform]
standardTransforms = [wptexifyXF, ghciXF, imagesXF, highlightXF]
centerImagesXF :: Transform
centerImagesXF = Transform (const . arr $ centerImages) (const True)
centerImages :: Pandoc -> Pandoc
centerImages = bottomUp centerImage
where
centerImage :: [Block] -> [Block]
centerImage (img@(Para [Image altText (imgUrl, imgTitle)]) : bs) =
RawBlock "html" "<div style=\"text-align: center;\">"
: img
: RawBlock "html" "</div>"
: bs
centerImage bs = bs
xformDoc :: BlogLiterately -> [Transform] -> (String -> IO String)
xformDoc bl xforms = runKleisli $
arr fixLineEndings
>>> arr (readMarkdown parseOpts)
>>> runTransforms xforms bl
>>> arr (writeHtml writeOpts)
>>> arr renderHtml
where
parseOpts = def
{ readerExtensions = Ext_literate_haskell
`S.insert` readerExtensions def
, readerSmart = True
}
writeOpts = def
{ writerReferenceLinks = True
, writerHTMLMathMethod =
case math bl of
"" -> PlainMath
opt -> mathOption opt }
mathOption opt
| opt `isPrefixOf` "latexmathml" ||
opt `isPrefixOf` "asciimathml" = LaTeXMathML (mathUrlMaybe opt)
| opt `isPrefixOf` "mathml" = MathML (mathUrlMaybe opt)
| opt `isPrefixOf` "mimetex" =
WebTeX (mathUrl "/cgi-bin/mimetex.cgi?" opt)
| opt `isPrefixOf` "webtex" = WebTeX (mathUrl webTeXURL opt)
| opt `isPrefixOf` "jsmath" = JsMath (mathUrlMaybe opt)
| opt `isPrefixOf` "mathjax" = MathJax (mathUrl mathJaxURL opt)
| opt `isPrefixOf` "gladtex" = GladTeX
webTeXURL = "http://chart.apis.google.com/chart?cht=tx&chl="
mathJaxURL = "http://cdn.mathjax.org/mathjax/latest/MathJax.js"
++ "?config=TeX-AMS-MML_HTMLorMML"
urlPart = drop 1 . dropWhile (/='=')
mathUrlMaybe opt = case urlPart opt of "" -> Nothing; x -> Just x
mathUrl def opt = case urlPart opt of "" -> def; x -> x
fixLineEndings :: String -> String
fixLineEndings [] = []
fixLineEndings ('\r':'\n':cs) = '\n':fixLineEndings cs
fixLineEndings (c:cs) = c:fixLineEndings cs