module Text.BlogLiterately.Transform
(
standardTransforms
, optionsXF
, profileXF
, highlightOptsXF
, passwordXF
, titleXF
, wptexifyXF
, ghciXF
, uploadImagesXF
, highlightXF
, centerImagesXF
, citationsXF
, Transform(..), pureTransform, ioTransform, runTransform, runTransforms
, xformDoc
, fixLineEndings
) where
import Control.Applicative ((<$>))
import Control.Arrow ((>>>))
import Control.Lens (has, isn't, use, (%=), (&),
(.=), (.~), (^.), _1, _2,
_Just)
import Control.Monad.State
import Data.List (intercalate, isPrefixOf)
import qualified Data.Map as M
import Data.Monoid (mappend)
import Data.Monoid (mempty, (<>))
import qualified Data.Set as S
import Data.Traversable (traverse)
import System.Directory (doesFileExist,
getAppUserDataDirectory)
import System.Exit (exitFailure)
import System.FilePath (takeExtension, (<.>), (</>))
import System.IO (hFlush, stdout)
import Text.Blaze.Html.Renderer.String (renderHtml)
import Text.CSL.Pandoc (processCites')
import Text.Pandoc
import Text.Pandoc.Error (PandocError)
import Text.Parsec (ParseError)
import Text.BlogLiterately.Block (onTag)
import Text.BlogLiterately.Ghci (formatInlineGhci)
import Text.BlogLiterately.Highlight (HsHighlight (HsColourInline),
colourisePandoc,
getStylePrefs,
_HsColourInline)
import Text.BlogLiterately.Image (uploadAllImages)
import Text.BlogLiterately.LaTeX (wpTeXify)
import Text.BlogLiterately.Options
import Text.BlogLiterately.Options.Parse (readBLOptions)
data Transform = Transform
{ getTransform :: StateT (BlogLiterately, Pandoc) IO ()
, xfCond :: BlogLiterately -> Bool
}
pureTransform :: (BlogLiterately -> Pandoc -> Pandoc)
-> (BlogLiterately -> Bool) -> Transform
pureTransform transf cond = Transform (gets fst >>= \bl -> _2 %= transf bl) cond
ioTransform :: (BlogLiterately -> Pandoc -> IO Pandoc)
-> (BlogLiterately -> Bool) -> Transform
ioTransform transf cond = Transform (StateT . fmap (fmap $ (,) ()) $ transf') cond
where transf' (bl,p) = ((,) bl) <$> transf bl p
runTransform :: Transform -> StateT (BlogLiterately, Pandoc) IO ()
runTransform t = do
bl <- gets fst
when (xfCond t bl) $ getTransform t
runTransforms :: [Transform] -> BlogLiterately -> Pandoc -> IO (BlogLiterately, Pandoc)
runTransforms ts bl p = execStateT (mapM_ runTransform ts) (bl,p)
wptexifyXF :: Transform
wptexifyXF = pureTransform (const wpTeXify) wplatex'
ghciXF :: Transform
ghciXF = ioTransform (formatInlineGhci . file') ghci'
uploadImagesXF :: Transform
uploadImagesXF = ioTransform uploadAllImages uploadImages'
highlightXF :: Transform
highlightXF = pureTransform
(\bl -> colourisePandoc (hsHighlight' bl) (otherHighlight' bl))
(const True)
centerImagesXF :: Transform
centerImagesXF = pureTransform (const 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
titleXF :: Transform
titleXF = Transform extractTitle (const True)
where
extractTitle = do
(Pandoc (Meta m) _) <- gets snd
case M.lookup "title" m of
Just (MetaString s) ->
setTitle s
Just (MetaInlines is) ->
setTitle (intercalate " " [s | Str s <- is])
_ -> return ()
setTitle s = _1.title %= (`mplus` Just s)
optionsXF :: Transform
optionsXF = Transform optionsXF' (const True)
where
optionsXF' = do
p <- gets snd
let (errs, opts) = queryWith extractOptions p
mapM_ (liftIO . print) errs
_1 %= (<> opts)
let p' = bottomUp killOptionBlocks p
_2 .= p'
extractOptions :: Block -> ([ParseError], BlogLiterately)
extractOptions = onTag "blopts" (const readBLOptions) (const mempty)
killOptionBlocks :: Block -> Block
killOptionBlocks = onTag "blopts" (const (const Null)) id
passwordXF :: Transform
passwordXF = Transform passwordPrompt passwordCond
where
passwordCond bl = ((bl ^. blog) & has _Just)
&& ((bl ^. password) & isn't _Just)
passwordPrompt = do
liftIO $ putStr "Password: " >> hFlush stdout
pwd <- liftIO getLine
_1 . password .= Just pwd
highlightOptsXF :: Transform
highlightOptsXF = Transform doHighlightOptsXF (const True)
where
doHighlightOptsXF = do
prefs <- (liftIO . getStylePrefs) =<< use (_1 . style)
(_1 . hsHighlight) %= Just . maybe (HsColourInline prefs)
(_HsColourInline .~ prefs)
citationsXF :: Transform
citationsXF = ioTransform (const processCites') citations'
profileXF :: Transform
profileXF = Transform doProfileXF (const True)
where
doProfileXF = do
bl <- use _1
bl' <- liftIO $ loadProfile bl
_1 .= bl'
loadProfile :: BlogLiterately -> IO BlogLiterately
loadProfile bl =
case bl^.profile of
Nothing -> return bl
Just profileName -> do
appDir <- getAppUserDataDirectory "BlogLiterately"
let profileCfg = appDir </> profileName <.> "cfg"
e <- doesFileExist profileCfg
case e of
False -> do
putStrLn $ profileCfg ++ ": file not found"
exitFailure
True -> do
(errs, blProfile) <- readBLOptions <$> readFile profileCfg
mapM_ print errs
return $ mappend blProfile bl
standardTransforms :: [Transform]
standardTransforms =
[
optionsXF
, profileXF
, passwordXF
, titleXF
, wptexifyXF
, ghciXF
, uploadImagesXF
, centerImagesXF
, highlightOptsXF
, highlightXF
, citationsXF
]
xformDoc :: BlogLiterately -> [Transform] -> String -> IO (Either PandocError (BlogLiterately, String))
xformDoc bl xforms =
fixLineEndings
>>> parseFile parseOpts
>>> traverse
( runTransforms xforms bl
>=> (\(bl', p) -> return $ (bl', writeHtml (writeOpts bl') p) )
>=> _2 (return . renderHtml)
)
where
parseFile :: ReaderOptions -> String -> Either PandocError Pandoc
parseFile opts =
case bl^.format of
Just "rst" -> readRST opts
Just _ -> readMarkdown opts
Nothing ->
case takeExtension (file' bl) of
".rst" -> readRST opts
".rest" -> readRST opts
".txt" -> readRST opts
_ -> readMarkdown opts
parseOpts = def
{ readerExtensions = Ext_literate_haskell
`S.insert` readerExtensions def
, readerSmart = True
}
writeOpts bl = def
{ writerReferenceLinks = True
, writerTableOfContents = toc' bl
, writerHTMLMathMethod =
case math' bl of
"" -> PlainMath
opt -> mathOption opt
, writerStandalone = True
, writerTemplate = blHtmlTemplate
}
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
| otherwise = PlainMath
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 dflt opt = case urlPart opt of "" -> dflt; x -> x
fixLineEndings :: String -> String
fixLineEndings [] = []
fixLineEndings ('\r':'\n':cs) = '\n':fixLineEndings cs
fixLineEndings (c:cs) = c:fixLineEndings cs
blHtmlTemplate = unlines
[ "$if(highlighting-css)$"
, " <style type=\"text/css\">"
, "$highlighting-css$"
, " </style>"
, "$endif$"
, "$for(css)$"
, " <link rel=\"stylesheet\" href=\"$css$\" $if(html5)$$else$type=\"text/css\" $endif$/>"
, "$endfor$"
, "$if(math)$"
, " $math$"
, "$endif$"
, "$if(toc)$"
, "<div id=\"$idprefix$TOC\">"
, "$toc$"
, "</div>"
, "$endif$"
, "$body$"
]