{-# LANGUAGE FlexibleInstances #-}{-# LANGUAGE OverloadedStrings #-}{-# LANGUAGE RecordWildCards #-}{-# LANGUAGE TypeOperators #-}------------------------------------------------------------------------------- |-- Module : Text.BlogLiterately.Transform-- Copyright : (c) 2008-2010 Robert Greayer, 2012-2013 Brent Yorgey-- License : GPL (see LICENSE)-- Maintainer : Brent Yorgey <byorgey@gmail.com>---- Tools for putting together a pipeline transforming the source for a-- post into a completely formatted HTML document.-------------------------------------------------------------------------------moduleText.BlogLiterately.Transform(-- * Standard transforms-- $standardstandardTransforms,optionsXF,profileXF,highlightOptsXF,passwordXF,titleXF,wptexifyXF,ghciXF,uploadImagesXF,highlightXF,centerImagesXF-- * Transforms,Transform(..),pureTransform,ioTransform,runTransform,runTransforms-- * Transforming documents,xformDoc-- * Utilities,fixLineEndings)whereimportControl.Applicative(pure,(<$>),(<**>))importControl.Arrow((>>>))importControl.Lens(has,isn't,set,use,(%=),(&),(.=),(.~),(^.),_1,_2,_Just)importControl.Monad.StateimportData.Default(def)importData.List(intercalate,isPrefixOf)importqualifiedData.MapasMimportData.Monoid(mappend)importData.Monoid(mempty,(<>))importqualifiedData.SetasSimportqualifiedData.TraversableasTimportSystem.Directory(doesFileExist,getAppUserDataDirectory)importSystem.Exit(exitFailure)importSystem.FilePath(takeExtension,(<.>),(</>))importSystem.IO(hFlush,stdout)importText.Blaze.Html.Renderer.String(renderHtml)importText.PandocimportText.Pandoc.OptionsimportText.Parsec(ParseError)importText.BlogLiterately.Block(onTag)importText.BlogLiterately.Ghci(formatInlineGhci)importText.BlogLiterately.Highlight(HsHighlight(HsColourInline),colourisePandoc,getStylePrefs,_HsColourInline)importText.BlogLiterately.Image(uploadAllImages)importText.BlogLiterately.LaTeX(wpTeXify)importText.BlogLiterately.OptionsimportText.BlogLiterately.Options.Parse(readBLOptions)-- | A document transformation consists of two parts: an actual-- transformation, expressed as a function over Pandoc documents, and-- a condition specifying whether the transformation should actually-- be applied.---- The transformation itself takes a 'BlogLiterately' configuration-- as an argument. You may of course ignore it if you do not need-- to know anything about the configuration. The @--xtra@ (or @-x@)-- flag is also provided especially as a method of getting-- information from the command-line to custom extensions. Arguments-- passed via @-x@ on the command line are available from the 'xtra'-- field of the 'BlogLiterately' configuration.---- The transformation is then specified as a stateful computation-- over both a @BlogLiterately@ options record, and a @Pandoc@-- document. It may also have effects in the @IO@ monad.---- * If you have a pure function of type @BlogLiterately -> Pandoc-- -> Pandoc@, you can use the 'pureTransform' function to create a-- 'Transform'.---- * If you have a function of type @BlogLiterately -> Pandoc -> IO-- Pandoc@, you can use 'ioTransform'.---- * Otherwise you can directly create something of type @StateT-- (BlogLiterately, Pandoc) IO ()@.---- For examples, see the implementations of the standard transforms-- below.dataTransform=Transform{getTransform::StateT(BlogLiterately,Pandoc)IO()-- ^ A document transformation, which can transform-- both the document and the options and have-- effects in the IO monad. The options record-- can be transformed because the document itself-- may contain information which affects the options.,xfCond::BlogLiterately->Bool-- ^ A condition under which to run the transformation.}-- | Construct a transformation from a pure function.pureTransform::(BlogLiterately->Pandoc->Pandoc)->(BlogLiterately->Bool)->TransformpureTransformtransfcond=Transform(getsfst>>=\bl->_2%=transfbl)cond-- | Construct a transformation from a function in the @IO@ monad.ioTransform::(BlogLiterately->Pandoc->IOPandoc)->(BlogLiterately->Bool)->TransformioTransformtransfcond=Transform(StateT.fmap(fmap$(,)())$transf')condwheretransf'(bl,p)=((,)bl)<$>transfblp-- | Run a 'Transform' (if its condition is met).runTransform::Transform->StateT(BlogLiterately,Pandoc)IO()runTransformt=dobl<-getsfstwhen(xfCondtbl)$getTransformt-- | Run a pipeline of 'Transform's.runTransforms::[Transform]->BlogLiterately->Pandoc->IO(BlogLiterately,Pandoc)runTransformstsblp=execStateT(mapM_runTransformts)(bl,p)---------------------------------------------------- Standard transforms---------------------------------------------------- $standard-- These transforms are enabled by default in the standard-- @BlogLiterately@ executable.-- | Format embedded LaTeX for WordPress (if the @wplatex@ flag is set).wptexifyXF::TransformwptexifyXF=pureTransform(constwpTeXify)wplatex'-- | Format embedded @ghci@ sessions (if the @ghci@ flag is set).ghciXF::TransformghciXF=ioTransform(formatInlineGhci.file')ghci'-- | Upload embedded local images to the server (if the @uploadImages@-- flag is set).uploadImagesXF::TransformuploadImagesXF=ioTransformuploadAllImagesuploadImages'-- | Perform syntax highlighting on code blocks.highlightXF::TransformhighlightXF=pureTransform(\bl->colourisePandoc(hsHighlight'bl)(otherHighlight'bl))(constTrue)-- | Center any images which occur in a paragraph by themselves.-- Inline images are not affected.centerImagesXF::TransformcenterImagesXF=pureTransform(constcenterImages)(constTrue)centerImages::Pandoc->PandoccenterImages=bottomUpcenterImagewherecenterImage::[Block]->[Block]centerImage(img@(Para[ImagealtText(imgUrl,imgTitle)]):bs)=RawBlock"html""<div style=\"text-align: center;\">":img:RawBlock"html""</div>":bscenterImagebs=bs-- | Potentially extract a title from the metadata block, and set it-- in the options record.titleXF::TransformtitleXF=TransformextractTitle(constTrue)whereextractTitle=do(Pandoc(Metam)_)<-getssndcaseM.lookup"title"mofJust(MetaStrings)->setTitlesJust(MetaInlinesis)->setTitle(intercalate" "[s|Strs<-is])_->return()-- title set explicitly with --title takes precedence.setTitles=_1.title%=(`mplus`Justs)-- | Extract blocks tagged with @[BLOpts]@ and use their contents as-- options.optionsXF::TransformoptionsXF=TransformoptionsXF'(constTrue)whereoptionsXF'=dop<-getssndlet(errs,opts)=queryWithextractOptionspmapM_(liftIO.print)errs_1%=(<>opts)letp'=bottomUpkillOptionBlocksp_2.=p'-- | Take a block and extract from it a list of parse errors and an-- options record. If the blog is not tagged with @[BLOpts]@ these-- will just be empty.extractOptions::Block->([ParseError],BlogLiterately)extractOptions=onTag"blopts"(constreadBLOptions)(constmempty)-- | Delete any blocks tagged with @[BLOpts]@.killOptionBlocks::Block->BlockkillOptionBlocks=onTag"blopts"(const(constNull))id-- | Prompt the user for a password if the @blog@ field is set but no-- password has been provided.passwordXF::TransformpasswordXF=TransformpasswordPromptpasswordCondwherepasswordCondbl=((bl^.blog)&has_Just)&&((bl^.password)&isn't_Just)passwordPrompt=doliftIO$putStr"Password: ">>hFlushstdoutpwd<-liftIOgetLine_1.password.=Justpwd-- | Read a user-supplied style file and add its contents to the-- highlighting options.highlightOptsXF::TransformhighlightOptsXF=TransformdoHighlightOptsXF(constTrue)wheredoHighlightOptsXF=doprefs<-(liftIO.getStylePrefs)=<<use(_1.style)(_1.hsHighlight)%=Just.maybe(HsColourInlineprefs)(_HsColourInline.~prefs)-- | Load options from a profile if one is specified.profileXF::TransformprofileXF=TransformdoProfileXF(constTrue)wheredoProfileXF=dobl<-use_1bl'<-liftIO$loadProfilebl_1.=bl'-- | Load additional options from a profile specified in the options-- record.loadProfile::BlogLiterately->IOBlogLiteratelyloadProfilebl=casebl^.profileofNothing->returnblJustprofileName->doappDir<-getAppUserDataDirectory"BlogLiterately"letprofileCfg=appDir</>profileName<.>"cfg"e<-doesFileExistprofileCfgcaseeofFalse->doputStrLn$profileCfg++": file not found"exitFailureTrue->do(errs,blProfile)<-readBLOptions<$>readFileprofileCfgmapM_printerrsreturn$mappendblProfilebl-- | The standard set of transforms that are run by default (in order-- from top to bottom):---- * 'optionsXF': extract options specified in @[BLOpts]@ blocks in the file---- * 'profileXF': load the requested profile (if any)---- * 'passwordXF': prompt the user for a password if needed---- * 'titleXF': extract the title from a special title block---- * 'wptexifyXF': turn LaTeX into WordPress format if requested---- * 'ghciXF': run and typeset ghci sessions if requested---- * 'uploadImagesXF': upload images if requested---- * 'centerImagesXF': center images occurring in their own paragraph---- * 'highlightOptsXF': load the requested highlighting style file---- * 'highlightXF': perform syntax highlighting--standardTransforms::[Transform]standardTransforms=[-- Has to go first, since it may affect later transforms.optionsXF-- Has to go second, since we may not know which profile to load-- until after the optionsXF pass, and loading a profile may-- affect later transforms.,profileXF-- The order of the rest of these probably doesn't matter that-- much, except highlightOptsXF should go before highlightXF.,passwordXF,titleXF,wptexifyXF,ghciXF,uploadImagesXF,centerImagesXF,highlightOptsXF,highlightXF]---------------------------------------------------- Transforming documents---------------------------------------------------- | Transform a complete input document string to an HTML output-- string, given a list of transformation passes.xformDoc::BlogLiterately->[Transform]->String->IO(BlogLiterately,String)xformDocblxforms=fixLineEndings>>>parseFileblparseOpts>>>runTransformsxformsbl>=>_2(return.writeHtmlwriteOpts)>=>_2(return.renderHtml)whereparseFileblopts=casebl^.formatofJust"rst"->readRSToptsJust_->readMarkdownoptsNothing->casetakeExtension(file'bl)of".rst"->readRSTopts".rest"->readRSTopts".txt"->readRSTopts_->readMarkdownoptsparseOpts=def{readerExtensions=Ext_literate_haskell`S.insert`readerExtensionsdef,readerSmart=True}writeOpts=def{writerReferenceLinks=True,writerHTMLMathMethod=casemath'blof""->PlainMathopt->mathOptionopt,writerStandalone=True,writerTemplate=unlines["$for(css)$"," <linkrel=\"stylesheet\" href=\"$css$\" $if(html5)$$else$type=\"text/css\" $endif$/>","$endfor$","$if(math)$"," $math$","$endif$","$body$"]}mathOptionopt|opt`isPrefixOf`"latexmathml"||opt`isPrefixOf`"asciimathml"=LaTeXMathML(mathUrlMaybeopt)|opt`isPrefixOf`"mathml"=MathML(mathUrlMaybeopt)|opt`isPrefixOf`"mimetex"=WebTeX(mathUrl"/cgi-bin/mimetex.cgi?"opt)|opt`isPrefixOf`"webtex"=WebTeX(mathUrlwebTeXURLopt)|opt`isPrefixOf`"jsmath"=JsMath(mathUrlMaybeopt)|opt`isPrefixOf`"mathjax"=MathJax(mathUrlmathJaxURLopt)|opt`isPrefixOf`"gladtex"=GladTeXwebTeXURL="http://chart.apis.google.com/chart?cht=tx&chl="mathJaxURL="http://cdn.mathjax.org/mathjax/latest/MathJax.js"++"?config=TeX-AMS-MML_HTMLorMML"urlPart=drop1.dropWhile(/='=')mathUrlMaybeopt=caseurlPartoptof""->Nothing;x->JustxmathUrldefopt=caseurlPartoptof""->def;x->x-- | Turn @CRLF@ pairs into a single @LF@. This is necessary since-- 'readMarkdown' is picky about line endings.fixLineEndings::String->StringfixLineEndings[]=[]fixLineEndings('\r':'\n':cs)='\n':fixLineEndingscsfixLineEndings(c:cs)=c:fixLineEndingscs