BlogLiterately 0.4 → 0.5
raw patch · 15 files changed
+1315/−696 lines, 15 filesdep +BlogLiteratelydep +bytestringdep +directorydep ~HaXmldep ~basedep ~haxr
Dependencies added: BlogLiterately, bytestring, directory, filepath, split
Dependency ranges changed: HaXml, base, haxr, pandoc, process
Files
- BlogLiterately.cabal +62/−17
- CHANGES +13/−0
- doc/BlogLiteratelyDoc.lhs +81/−11
- main/BlogLiterately.hs +3/−0
- src/BlogLiterately.lhs +0/−668
- src/Text/BlogLiterately.hs +32/−0
- src/Text/BlogLiterately/Block.hs +32/−0
- src/Text/BlogLiterately/Ghci.hs +227/−0
- src/Text/BlogLiterately/Highlight.hs +280/−0
- src/Text/BlogLiterately/Image.hs +104/−0
- src/Text/BlogLiterately/LaTeX.hs +41/−0
- src/Text/BlogLiterately/Options.hs +108/−0
- src/Text/BlogLiterately/Post.hs +114/−0
- src/Text/BlogLiterately/Run.hs +79/−0
- src/Text/BlogLiterately/Transform.hs +139/−0
BlogLiterately.cabal view
@@ -1,23 +1,42 @@ Name: BlogLiterately-Version: 0.4+Version: 0.5 Synopsis: A tool for posting Haskelly articles to blogs Description: Write blog posts in Markdown format, then use BlogLiterately to do syntax highlighting, format ghci sessions, and upload to any blog supporting the metaWeblog API (such as Wordpress). .- See <http://byorgey.wordpress.com/blogliterately/> for complete- documentation.-Cabal-Version: >= 1.6+ To get started, use the provided executable+ @BlogLiterately@; see+ <http://byorgey.wordpress.com/blogliterately/> for+ complete documentation.+ .+ To make further customization possible, the internals+ of the executable are made available as a library. In+ particular, it is easy to create your own executable+ which adds extra custom transformations; see+ "Text.BlogLiterately.Run".+ .+ Note that BlogLiterately depends on blaze-html-0.5.+ Pandoc 1.9.3 and later can depend on either+ blaze-html-0.4 or blaze-html-0.5, but the latter only+ in case the blaze_html_0_5 flag is set. If pandoc is+ installed as a dependency of BlogLiterately,+ everything should work out fine, since cabal's+ constraint solver will figure out to set that flag.+ But if pandoc is already installed against+ blaze-html-0.4 you may need to reinstall it with the+ blaze_html_0_5 flag explicitly set.+Cabal-Version: >= 1.8 Homepage: http://byorgey.wordpress.com/blogliterately/ License: GPL License-file: LICENSE-Category: Web-Copyright: Copyright (c) Robert Greayer 2008-2010, Brent Yorgey 2012+Category: Web+Copyright: Copyright (c) Robert Greayer 2008-2010, Brent Yorgey 2012 Author: Robert Greayer <robgreayer@yahoo.com>-Maintainer: Brent Yorgey <byorgey@cis.upenn.edu>-Stability: experimental+Maintainer: Brent Yorgey <byorgey@cis.upenn.edu>+Stability: experimental Build-Type: Simple-Tested-With: GHC ==7.4.1+Tested-With: GHC ==7.4.1 Extra-Source-Files: CHANGES doc/BlogLiteratelyDoc.lhs style/*.css@@ -26,13 +45,39 @@ type: darcs location: http://patch-tag.com/r/byorgey/BlogLiterately +Library+ Build-Depends: base >= 4.0 && < 4.6,+ process,+ filepath,+ directory,+ bytestring,+ split >= 0.1.4 && < 0.2,+ utf8-string >= 0.3 && < 0.4,+ transformers >= 0.3 && < 0.4,+ parsec >= 3 && < 3.2,+ HaXml >= 1.22 && < 1.24,+ hscolour >= 1.20 && < 1.21,+ blaze-html >= 0.5 && < 0.6,+ cmdargs >= 0.9.5 && < 0.10,+ haxr >= 3000.9 && < 3000.10,+ pandoc >= 1.9.3 && < 1.10+ Exposed-modules: Text.BlogLiterately+ Text.BlogLiterately.Block+ Text.BlogLiterately.Ghci+ Text.BlogLiterately.Highlight+ Text.BlogLiterately.Image+ Text.BlogLiterately.LaTeX+ Text.BlogLiterately.Options+ Text.BlogLiterately.Post+ Text.BlogLiterately.Run+ Text.BlogLiterately.Transform+ hs-source-dirs: src+ Executable BlogLiterately- Build-Depends: base >= 4.0 && < 4.6, process >= 1.1 && < 1.2,- transformers >= 0.3 && < 0.4, parsec >= 3 && < 3.2,- HaXml >= 1.22 && < 1.23, utf8-string >= 0.3 && < 0.4,- hscolour >= 1.20 && < 1.21, blaze-html >= 0.5 && < 0.6,- cmdargs >= 0.9.5 && < 0.10,- haxr >= 3000.8 && < 3000.9, pandoc >= 1.9 && < 1.10- Main-Is: BlogLiterately.lhs- Hs-Source-Dirs: src+ Build-Depends: base,+ BlogLiterately,+ cmdargs >= 0.9.5 && < 0.10,+ utf8-string >= 0.3 && < 0.4+ Main-Is: BlogLiterately.hs+ hs-source-dirs: main Ghc-Options: -fwarn-unused-imports
CHANGES view
@@ -1,3 +1,16 @@+0.5: 7 July 2012++ * expose internals as a library, and create framework for adding+ custom transformations to the pipeline++ * image uploads++ * ability to specify expected outputs in ghci blocks++ * prompt for password if not provided++ * bump HaXml upper bound to allow 1.23.*+ 0.4: 2 July 2012 * Add special support for wordpress.com's LaTeX format
doc/BlogLiteratelyDoc.lhs view
@@ -157,6 +157,34 @@ txt <- readFile "BlogLiteratelyDoc.lhs" length txt +Additionally, lines indented by one or more space are interpreted as+*expected outputs* instead of inputs. Consecutive indented lines are+interpreted as one multi-line expected output, with a number of spaces+removed from the beginning of each line equal to the number of spaces+at the start of the first indented line.++If the output for a given input is the same as the expected output (or+if no expected output is given), the result is typeset normally. If+the actual and expected outputs differ, the actual output is typeset+first in red, then the expected output in blue. For example,++ [other]+ [ghci]+ reverse "kayak"+ 7+18+ 25+ hailstone 15+ 107834++produces++ [ghci]+ reverse "kayak"+ 7+18+ 25+ hailstone 15+ 107834+ There are currently a few known limitations of this feature: * The code for interfacing with `ghci` is not very robust. In@@ -171,17 +199,51 @@ * The formatting of `ghci` sessions currently cannot be customized. Suggestions for customizations to allow are welcome. +* Due to the very hacky way that `ghci` interaction is implemented,+ the usual `it` variable bound to the result of the previous expression+ is not available (rather, it *is* available... but is always equal to+ `()`).+ Uploading embedded images ------------------------- -A planned feature for a future release of `BlogLiterately` is the-ability to automatically upload images embedded in a blog post to the-server, replacing local image file names with the appropriate URL.-However, this feature is currently [blocked on a baffling-bug](http://stackoverflow.com/questions/11277788/errorclosed-exception-from-network-http-simplehttp-trying-to-upload-images-vi).-If you know anything about HTTP, TCP/IP, XML-RPC, WordPress, and/or-the `HTTP` and `haxr` libraries, please help!+When passed the `--upload-images` option, `BlogLiterately` can take+any images referenced locally and automatically upload them to the+server, replacing the local references with appropriate URLs. +To include images in blog posts, use the Markdown syntax++ ++The URL determines whether the image will be uploaded. A *remote* URL+is any beginning with `http` or a forward slash (interpreted as a URL+relative to the server root). In all other cases it is assumed that+the URL in fact represents a relative path on the local file system.+Such images, if they exist, will be uploaded to the server (using the+`metaWeblog.newMediaObject` RPC call), and the local file name+replaced with the URL returned by the server.++A few caveats:++* There is no mechanism for uploading only some of the images. So if+ you upload a post with a bunch of images but then want to change just+ one of the images, you must either re-upload them all, or upload the+ single image manually.++* Also, the `newMediaObject` call has an optional `replace` parameter, but+ `BlogLiterately` does not use it, since it's too dangerous: if+ `replace` is set and you happen to use the same file name as some+ other image file that already exists on your blog, the old image would+ be deleted. However, this means that if you upload an image multiple+ times you will get multiple copies on your blog.++* As a consequence of the above, best practice is probably to write your+ post while doing a combination of previewing locally to see the post+ with images and uploading without the `--upload-images` flag to see+ what the post looks like on your blog (except with a bunch of broken+ images). Once you're confident everything looks good, do a final+ upload with `--upload-images` (and perhaps `--publish`) set.+ Command-line options -------------------- @@ -202,6 +264,7 @@ --other-kate highlight other code with highlighting-kate -w --wplatex reformat inline LaTeX the way WordPress expects -g --ghci run [ghci] blocks through ghci and include output+ --upload-images upload local images --category=ITEM post category (can specify more than one) --tag=ITEM tag (can specify more than one) --blogid=ID Blog specific identifier@@ -212,6 +275,7 @@ --postid=ID Post to replace (if any) --page create a "page" instead of a post (WordPress only) --publish publish post (otherwise it's uploaded as a draft)+ -x --xtra=ITEM extension arguments, for use with custom extensions -? --help Display help message -V --version Print version information @@ -230,14 +294,20 @@ BlogLiterately --blog http://blogurl.example.com/xmlrpc.php \ --user myname --password mypasswd --title "Sample" Sample.lhs -(which creates a new post). If, for example, the post id of that post-(which `BlogLiterately` prints when it uploads a new post) is '37', then-to update the post, the command would be:+(which creates a new post). You can also omit the `--password` field,+in which case `BlogLiterately` will prompt you for your password. +If the post id of that post (which `BlogLiterately` prints when it+uploads a new post) is '37', then to update the post, the command+would be something like+ BlogLiterately --postid 37 --blog http://blogurl.example.com/xmlrpc.php \ --user myname --password mypasswd --title "Sample" Sample.lhs -and the post will be updated with the new text.+and the post will be updated with the new text. In both cases the+post is uploaded as a draft. To publish the post, you can pass the+`--publish` option (or, of course, you can flip the publish bit+manually on the server). Getting Help ------------
+ main/BlogLiterately.hs view
@@ -0,0 +1,3 @@+import Text.BlogLiterately.Run++main = blogLiterately
− src/BlogLiterately.lhs
@@ -1,668 +0,0 @@-BlogLiterately is a tool for uploading blog posts to servers that-support the MetaWeblog API (such as WordPress-based blogs and many-others). It also handles syntax highlighting of Haskell and other-languages.--> {-# LANGUAGE TypeOperators #-}-> {-# LANGUAGE DeriveDataTypeable #-}-> {-# LANGUAGE RecordWildCards #-}-> module Main where--We need [Pandoc][] for parsing [Markdown][]:--> import Text.Pandoc-> import Text.Pandoc.Highlighting ( highlight, formatHtmlBlock )--And [hscolour][] for highlighting:--> import Language.Haskell.HsColour ( hscolour, Output(..) )-> import Language.Haskell.HsColour.Colourise ( defaultColourPrefs )--To post to a blog, we need the [MetaWeblog][] API, which is an-XML-RPC-based protocol for interacting with blogs.--We'll use the Haskell XML-RPC library, [HaXR][], by Bjorn Bringert,-(on [hackage][hackage-haxr]).--> import Network.XmlRpc.Client ( remote )-> import Network.XmlRpc.Internals ( XmlRpcType(toValue) )--We use Neil Mitchell's [CmdArgs][] library for processing command-line-arguments:--> import System.Console.CmdArgs--We also need to parse and manipulate XHTML, so we'll use Malcolm-Wallace's [HaXml][] XML combinators, and blaze-html for rendering-HTML:--> import Text.XML.HaXml-> import Text.XML.HaXml.Posn ( noPos )-> import Text.Blaze.Html.Renderer.String ( renderHtml )--Finally, some miscellaneous/standard imports:--> import Control.Arrow ( first, (>>>), arr-> , Kleisli(..), runKleisli )-> import qualified Control.Category as C ( Category, id )-> import Control.Monad ( liftM, unless )-> import Control.Monad.IO.Class ( liftIO )-> import Control.Monad.Trans.Reader ( ReaderT, runReaderT, ask )-> import Data.Functor ( (<$>) )-> import Data.List ( isPrefixOf, intercalate )-> import System.IO-> import qualified System.IO.UTF8 as U ( readFile )-> import System.Process ( ProcessHandle, waitForProcess-> , runInteractiveCommand )-> import Text.ParserCombinators.Parsec--The program will read in a literate Haskell file, use Pandoc to parse-it as markdown, and, if it is using hscolour to for the Haskell-pieces, hscolour to transform those. Pandoc turns its input into a-structure of type:-- [haskell]- data Pandoc = Pandoc Meta [Block]- -where a `Block` (the interesting bit, for our purposes) looks like:-- [haskell]- -- | Block element.- data Block- = Plain [Inline] -- ^ Plain text, not a paragraph- | Para [Inline] -- ^ Paragraph- | CodeBlock Attr String -- ^ Code block (literal) with attributes- | RawBlock Format String -- ^ Raw block- | BlockQuote [Block] -- ^ Block quote (list of blocks)- | OrderedList ListAttributes [[Block]] -- ^ Ordered list (attributes- -- and a list of items, each a list of blocks)- | BulletList [[Block]] -- ^ Bullet list (list of items, each- -- a list of blocks)- | DefinitionList [([Inline],[[Block]])] -- ^ Definition list- -- Each list item is a pair consisting of a- -- term (a list of inlines) and one or more- -- definitions (each a list of blocks)- | Header Int [Inline] -- ^ Header - level (integer) and text (inlines)- | HorizontalRule -- ^ Horizontal rule- | Table [Inline] [Alignment] [Double] [TableCell] [[TableCell]] -- ^ Table,- -- with caption, column alignments,- -- relative column widths (0 = default),- -- column headers (each a list of blocks), and- -- rows (each a list of lists of blocks)- | Null -- ^ Nothing- deriving (Eq, Ord, Read, Show, Typeable, Data GENERIC)--The literate Haskell that Pandoc finds in a file ends up in various-`CodeBlock` elements of the `Pandoc` document. Other code can also-wind up in `CodeBlock` elements -- normal markdown formatted code.-The `Attr` component has metadata about what's in the code block:-- [haskell]- type Attr = ( String, -- code block identifier- , [String] -- list of code classes- , [(String, String)] -- name/value pairs- )--Thanks to some feedback from the Pandoc author, John MacFarlane, I-learned that the CodeBlock *may* contain markers about the kind of-code contained within the block. LHS (bird-style or LaTex style) will-always have an `Attr` of the form `("",["sourceCode","haskell"],[])`,-and other `CodeBlock` elements are the markdown code blocks *may* have-an identifier, classes, or key/value pairs. Pandoc captures this info-when the file contains code blocks in the delimited (rather than-indented) format, which allows an optional meta-data specification,-e.g.--~~~~~~~~~~~-~~~~~~~ { .bash }-x=$1-echo $x-~~~~~~~-~~~~~~~~~~~--Although Pandoc supports the above format for marking code blocks (and-annotating the kind of code within the block) I'll also keep my-notation as another option for use with indented blocks, i.e. if you-write:--<pre><code>- [haskell]- foo :: String -> String-</code></pre>--it is a Haskell block. You can also use other annotations, *e.g.*--<pre><code>- [cpp]- cout << "Hello World!";-</code></pre>--If highlighting-kate is specified for highlighting Haskell blocks, the-distinction between the literate blocks and the delimited blocks is-lost (this is simply how the Pandoc highlighting module currently-works).--I'll adopt the rule that if you specify a class or classes using-Pandoc's delimited code block syntax, I'll assume that there is no-additional tag within the block in Blog Literately syntax. I still-need my `unTag` function to parse the code block.--> unTag :: String -> (String, String)-> unTag s = either (const ("",s)) id $ parse tag "" s-> where-> tag = do-> tg <- between (char '[') (char ']') $ many $ noneOf "[]"-> skipMany $ oneOf " \t"-> (string "\r\n" <|> string "\n")-> txt <- many $ anyToken-> eof-> return (tg,txt)--To highlight the syntax using hscolour (which produces HTML), I'm-going to need to transform the `String` from a `CodeBlock` element to-a `String` suitable for the `RawHtml` element (because the hscolour-library transforms Haskell text to HTML). Pandoc strips off the-prepended > characters from the literate Haskell, so I need to put-them back, and also tell hscolour whether the source it is colouring-is literate or not. The hscolour function looks like:-- [haskell]- hscolour :: Output -- ^ Output format.- -> ColourPrefs -- ^ Colour preferences...- -> Bool -- ^ Whether to include anchors.- -> Bool -- ^ Whether output document is partial or complete.- -> String -- ^ Title for output.- -> Bool -- ^ Whether input document is literate haskell- -> String -- ^ Haskell source code.- -> String -- ^ Coloured Haskell source code.--Since I still don't like the `ICSS` output from hscolour, I'm going to-provide two options for hscolouring to users: one that simply uses-hscolour's `CSS` format, so the user can provide definitions in their-blog's stylesheet to control the rendering, and a post-processing-option to transform the `CSS` class-based rendering into a inline-style based rendering (for people who can't update their stylesheet).-`colourIt` performs the initial transformation:--> colourIt literate srcTxt =-> hscolour CSS defaultColourPrefs False True "" literate srcTxt'-> where srcTxt' | literate = prepend srcTxt-> | otherwise = srcTxt--Prepending the literate Haskell markers on the source:--> prepend = unlines . map ("> " ++) . lines--Hscolour uses HTML `span` elements and CSS classes like 'hs-keyword'-or `hs-keyglyph` to markup Haskell code. What I want to do is take-each marked `span` element and replace the `class` attribute with an-inline `style` element that has the markup I want for that kind of-source. Style preferences are specified as a list of name/value-pairs:--> type StylePrefs = [(String,String)]--Here's a default style that produces something like what the source-listings on Hackage look like:--> defaultStylePrefs = [-> ("hs-keyword","color: blue; font-weight: bold;")-> , ("hs-keyglyph","color: red;")-> , ("hs-layout","color: red;")-> , ("hs-comment","color: green;")-> , ("hs-conid", "")-> , ("hs-varid", "")-> , ("hs-conop", "")-> , ("hs-varop", "")-> , ("hs-str", "color: teal;")-> , ("hs-chr", "color: teal;")-> , ("hs-number", "")-> , ("hs-cpp", "")-> , ("hs-selection", "")-> , ("hs-variantselection", "")-> , ("hs-definition", "")]--I can read these preferences in from a file using the `Read` instance-for `StylePrefs`. I could handle errors better, but this should work:--> getStylePrefs "" = return defaultStylePrefs-> getStylePrefs fname = liftM read (U.readFile fname)--Hscolour produces a `String` of HTML. To 'bake' the styles into the-HTML, we need to parse it, manipulate it and then re-render it as a-`String`. We use HaXml to do all of this:--> bakeStyles :: StylePrefs -> String -> String-> bakeStyles prefs s = verbatim $ filtDoc (xmlParse "bake-input" s)-> where->-> -- filter the document (an Hscoloured fragment of Haskell source)-> filtDoc (Document p s e m) = c where-> [c] = filts (CElem e noPos)->-> -- the filter is a fold of individual filters for each CSS class-> filts = mkElem "pre" [(foldXml $ foldl o keep $ map filt prefs) `o` replaceTag "code"]->-> -- an individual filter replaces the attributes of a tag with-> -- a style attribute when it has a specific 'class' attribute.-> filt (cls,style) =-> replaceAttrs [("style",style)] `when`-> (attrval $ (N "class", AttValue [Left cls]))--Highlighting-Kate uses <br/> in code blocks to indicate newlines.-WordPress (if not other software) chooses to strip them away when-found in <pre> sections of uploaded HTML. So we need to turn them-back to newlines.--> replaceBreaks :: String -> String-> replaceBreaks s = verbatim $ filtDoc (xmlParse "input" s)-> where-> -- filter the document (a highlighting-kate highlighted fragment of-> -- haskell source)-> filtDoc (Document p s e m) = c where-> [c] = filts (CElem e noPos)-> filts = foldXml (literal "\n" `when` tag "br")--Note to self: the above is a function that could be made better in a-few ways and then factored out into a library. A way to handle the-above would be to allow the preferences to be specified as an actual-CSS style sheet, which then would be baked into the HTML. Such a-function could be separately useful, and could be used to 'bake' in-the highlighting-kate styles.--To completely colourise/highlight a `CodeBlock` we now can create a-function that transforms a `CodeBlock` into a `RawHtml` block, where-the content contains marked up Haskell (possibly with literate-markers), or marked up non-Haskell, if highlighting of non-Haskell has-been selected.--> colouriseCodeBlock :: HsHighlight -> Bool -> Block -> Block-> colouriseCodeBlock hsHighlight otherHighlight b@(CodeBlock attr@(_,classes,_) s)->-> | tag == "haskell" || haskell-> = case hsHighlight of-> HsColourInline style ->-> RawBlock "html" $ bakeStyles style $ colourIt lit src-> HsColourCSS -> RawBlock "html" $ colourIt lit src-> HsNoHighlight -> RawBlock "html" $ simpleHTML hsrc-> HsKate -> if null tag-> then myHighlightK attr hsrc-> else myHighlightK ("",tag:classes,[]) hsrc->-> | otherHighlight-> = case tag of-> "" -> myHighlightK attr src-> t -> myHighlightK ("",[t],[]) src->-> | otherwise-> = RawBlock "html" $ simpleHTML src->-> where-> (tag,src)-> | null classes = unTag s-> | otherwise = ("",s)-> hsrc-> | lit = prepend src-> | otherwise = src-> lit = "sourceCode" `elem` classes-> haskell = "haskell" `elem` classes-> simpleHTML s = "<pre><code>" ++ s ++ "</code></pre>"-> myHighlightK attr s = case highlight formatHtmlBlock attr s of-> Nothing -> RawBlock "html" $ simpleHTML s-> Just html -> RawBlock "html" $ replaceBreaks $ renderHtml html->-> colouriseCodeBlock _ _ b = b--Colourising a `Pandoc` document is simply:--> colourisePandoc hsHighlight otherHighlight (Pandoc m blocks) =-> Pandoc m $ map (colouriseCodeBlock hsHighlight otherHighlight) blocks--WordPress can render LaTeX, but expects it in a special (non-standard)-format (`\$latex foo\$`). The `wpTeXify` function formats LaTeX code-using this format so that it can be processed by WordPress.--> wpTeXify :: Pandoc -> Pandoc-> wpTeXify = bottomUp formatDisplayTex . bottomUp formatInlineTex-> where formatInlineTex :: [Inline] -> [Inline]-> formatInlineTex (Math InlineMath tex : is)-> = (Str $ "$latex " ++ unPrefix "latex" tex ++ "$") : is-> formatInlineTex is = is->-> formatDisplayTex :: [Block] -> [Block]-> formatDisplayTex (Para [Math DisplayMath tex] : bs)-> = RawBlock "html" "<p><div style=\"text-align: center\">"-> : Plain [Str $ "$latex " ++ "\\displaystyle " ++ unPrefix "latex" tex ++ "$"]-> : RawBlock "html" "</div></p>"-> : bs-> formatDisplayTex bs = bs->-> unPrefix pre s-> | pre `isPrefixOf` s = drop (length pre) s-> | otherwise = s--The next bit of code enables using code blocks marked with `[ghci]` as-input to ghci and then inserting the results. This code was mostly-stolen from lhs2TeX.--> type ProcessInfo = (Handle, Handle, Handle, ProcessHandle)--First, a way to evaluate an expression using an external ghci process.--> ghciEval :: String -> ReaderT ProcessInfo IO String-> ghciEval expr = do-> (pin, pout, _, _) <- ask-> let script = "putStrLn " ++ show magic ++ "\n"-> ++ expr ++ "\n"-> ++ "putStrLn " ++ show magic ++ "\n"-> liftIO $ do-> hPutStr pin script-> hFlush pin-> extract' pout->-> withGhciProcess :: FilePath -> ReaderT ProcessInfo IO a -> IO a-> withGhciProcess f m = do-> isLit <- isLiterate f-> pi <- runInteractiveCommand $ "ghci -v0 -ignore-dot-ghci "-> ++ (if isLit then f else "")-> res <- runReaderT m pi-> stopProcess pi-> return res->-> isLiterate :: FilePath -> IO Bool-> isLiterate f = (any ("> " `isPrefixOf`) . lines) <$> readFile f->-> stopProcess :: ProcessInfo -> IO ()-> stopProcess (pin,_,_,pid) = do-> hPutStrLn pin ":q"-> hFlush pin-> _ <- waitForProcess pid -- ignore exit code-> return ()--To extract the answer from @ghci@'s output we use a simple technique-which should work in most cases: we print the string |magic| before-and after the expression we are interested in. We assume that-everything that appears before the first occurrence of |magic| on the-same line is the prompt, and everything between the first |magic| and-the second |magic| plus prompt is the result we look for.--> magic :: String-> magic = "!@#$^&*"->-> extract' :: Handle -> IO String-> extract' h = fmap (extract . unlines) (readMagic 2)-> where-> readMagic :: Int -> IO [String]-> readMagic 0 = return []-> readMagic n = do-> l <- hGetLine h-> let n' | (null . snd . breaks (isPrefixOf magic)) l = n-> | otherwise = n - 1-> fmap (l:) (readMagic n')->-> extract :: String -> String-> extract s = v-> where (t, u) = breaks (isPrefixOf magic) s-> -- t contains everything up to magic, u starts with magic-> -- |u' = tail (dropWhile (/='\n') u)|-> pre = reverse . takeWhile (/='\n') . reverse $ t-> prelength = if null pre then 0 else length pre + 1-> -- pre contains the prefix of magic on the same line-> u' = drop (length magic + prelength) u-> -- we drop the magic string, plus the newline, plus the prefix-> (v, _) = breaks (isPrefixOf (pre ++ magic)) u'-> -- we look for the next occurrence of prefix plus magic->-> breaks :: ([a] -> Bool) -> [a] -> ([a], [a])-> breaks p [] = ([], [])-> breaks p as@(a : as')-> | p as = ([], as)-> | otherwise = first (a:) $ breaks p as'--Finally, a function which takes the path to the `.lhs` source and its-representation as a `Pandoc` document, finds any `[ghci]` blocks in-it, runs them through `ghci`, and formats the results as an-interactive `ghci` session.--> formatInlineGhci :: FilePath -> Pandoc -> IO Pandoc-> formatInlineGhci f = withGhciProcess f . bottomUpM formatInlineGhci'-> where-> formatInlineGhci' :: Block -> ReaderT ProcessInfo IO Block-> formatInlineGhci' b@(CodeBlock attr s)-> | tag == "ghci" = do-> results <- zip inputs <$> mapM ghciEval inputs-> return $ CodeBlock attr (intercalate "\n" $ map formatGhciResult results)->-> | otherwise = return b->-> where (tag,src) = unTag s-> inputs = lines src->-> formatInlineGhci' b = return b->-> formatGhciResult (input, output)-> = "<span style=\"color: gray;\">ghci></span> " ++ input ++ (unlines . map (" "++) . lines) output -- XXX this should be configurable!--A useful arrow utility, for running some part of a pipeline-conditionally:--> whenA :: C.Category (~>) => (a ~> a) -> Bool -> (a ~> a)-> whenA a p | p = a-> | otherwise = C.id--Finally, putting everything together to transform a complete input-document string to an HTML output string. Note this may involve-running `ghci`.--> xformDoc :: BlogLiterately -> (String -> IO String)-> xformDoc bl@(BlogLiterately {..}) = runKleisli $-> arr fixLineEndings-> >>> arr (readMarkdown parseOpts) -- from Pandoc-> >>> arr wpTeXify `whenA` wplatex-> >>> Kleisli (formatInlineGhci file) `whenA` ghci-> -- >>> Kleisli (uploadAllImages bl)-> >>> arr (colourisePandoc hsHighlight otherHighlight)-> >>> arr (writeHtml writeOpts) -- from Pandoc-> >>> arr renderHtml-> where-> writeOpts = defaultWriterOptions-> { writerReferenceLinks = True }-> parseOpts = defaultParserState-> { stateLiterateHaskell = True }->-> -- readMarkdown is picky about line endings-> fixLineEndings [] = []-> fixLineEndings ('\r':'\n':cs) = '\n':fixLineEndings cs-> fixLineEndings (c:cs) = c:fixLineEndings cs--The metaWeblog API defines `newPost` and `editPost` procedures that-look like:-- [other]- metaWeblog.newPost (blogid, username, password, struct, publish)- returns string- metaWeblog.editPost (postid, username, password, struct, publish)- returns true--For WordPress blogs, the `blogid` is ignored. The user name and-password are simply strings, and `publish` is a flag indicating-whether to load the post as a draft, or to make it public immediately.-The `postid` is an identifier string which is assigned when you-initially create a post. The interesting bit is the `struct` field,-which is an XML-RPC structure defining the post along with some-meta-data, like the title. I want be able to provide the post body, a-title, and lists of categories and tags. For the body and title, we-could just let HaXR convert the values automatically into the XML-RPC-`Value` type, since they all have the same Haskell type (`String`) and-thus can be put into a list. But the categories and tags are lists of-strings, so we need to explicitly convert everything to a `Value`,-then combine:--> mkPost title text categories tags page =-> mkArray "categories" categories-> ++ mkArray "mt_keywords" tags-> ++ [ ("title", toValue title)-> , ("description", toValue text)-> ]-> ++ [ ("post_type", toValue "page") | page ]->-> mkArray _ [] = []-> mkArray name values = [(name, toValue values)]--The HaXR library exports a function for invoking XML-RPC procedures:-- [haskell]- remote :: Remote a =>- String -- ^ Server URL. May contain username and password on- -- the format username:password\@ before the hostname.- -> String -- ^ Remote method name.- -> a -- ^ Any function- -- @(XmlRpcType t1, ..., XmlRpcType tn, XmlRpcType r) =>- -- t1 -> ... -> tn -> IO r@--The function requires an URL and a method name, and returns a function-of type `Remote a => a`. Based on the instances defined for `Remote`,-any function with zero or more parameters in the class `XmlRpcType`-and a return type of `XmlRpcType r => IO r` will work, which means you-can simply 'feed' `remote` additional arguments as required by the-remote procedure, and as long as you make the call in an IO context,-it will typecheck. `postIt` calls `metaWeblog.newPost` or-`metaWeblog.editPost` (or simply prints the HTML to stdout) as-appropriate:--> postIt :: BlogLiterately -> String -> IO ()-> postIt (BlogLiterately{..}) html =-> case blog of-> Nothing -> putStr html-> Just url ->-> case postid of-> Nothing -> do-> pid <- remote url "metaWeblog.newPost" blogid user password-> (mkPost title html categories tags page) publish-> putStrLn $ "Post ID: " ++ pid-> Just pid -> do-> success <- remote url "metaWeblog.editPost" pid user password-> (mkPost title html categories tags page) publish-> unless success $ putStrLn "update failed!"--There are four modes of Haskell highlighting:--> data HsHighlight =-> HsColourInline StylePrefs-> | HsColourCSS-> | HsKate-> | HsNoHighlight-> deriving (Data,Typeable,Show,Eq)--And two modes for other code (off or on!).--To create a command line program, we capture the command line controls-in a type:--> data BlogLiterately = BlogLiterately-> { style :: String -- name of a style file-> , hsHighlight :: HsHighlight -- Haskell highlighting mode-> , otherHighlight :: Bool -- use highlighting-kate for non-Haskell?-> , wplatex :: Bool -- format LaTeX for WordPress?-> , ghci :: Bool -- automatically generate ghci sessions?-> -- , uploadImages :: Bool -- automatically upload images?-> , categories :: [String] -- categories for the post-> , tags :: [String] -- tags for the post-> , blogid :: String -- blog-specific identifier (e.g. for blogging-> -- software handling multiple blogs)-> , blog :: Maybe String -- blog xmlrpc URL-> , user :: String -- blog user name-> , password :: String -- blog password-> , title :: String -- post title-> , file :: String -- file to post-> , postid :: Maybe String -- id of a post to update-> , page :: Bool -- create a "page" instead of a post-> , publish :: Bool -- Should the post be published, or-> -- loaded as a draft?-> }-> deriving (Show,Data,Typeable)--And using CmdArgs, this bit of impure evil defines how the command-line arguments work:--> bl = BlogLiterately-> { style = "" &= help "style specification (for --hscolour-icss)"-> &= typFile-> , hsHighlight = enum-> [ (HsColourInline defaultStylePrefs)-> &= explicit-> &= name "hscolour-icss"-> &= help "highlight haskell: hscolour, inline style (default)"-> , HsColourCSS-> &= explicit-> &= name "hscolour-css"-> &= help "highlight haskell: hscolour, separate stylesheet"-> , HsNoHighlight-> &= explicit-> &= name "hs-nohighlight"-> &= help "no haskell highlighting"-> , HsKate-> &= explicit-> &= name "hs-kate"-> &= help "highlight haskell with highlighting-kate"-> ]-> , otherHighlight = enum-> [ True-> &= explicit-> &= name "other-kate"-> &= help "highlight other code with highlighting-kate"-> ]-> , wplatex = def &= help "reformat inline LaTeX the way WordPress expects"-> , ghci = def &= help "run [ghci] blocks through ghci and include output"-> -- , uploadImages = def &= name "upload-images" &= explicit &= help "upload local images"-> , page = def &= help "create a \"page\" instead of a post (WordPress only)"-> , publish = def &= help "publish post (otherwise it's uploaded as a draft)"-> , categories = def-> &= explicit-> &= name "category"-> &= help "post category (can specify more than one)"-> , tags = def-> &= explicit-> &= name "tag"-> &= help "tag (can specify more than one)"->-> , blogid = "default" &= help "Blog specific identifier" &= typ "ID"-> , postid = def &= help "Post to replace (if any)" &= typ "ID"->-> , blog = def &= typ "URL" &= help "blog XML-RPC url (if omitted, html goes to stdout)"-> , user = def &= typ "USER" &= help "user name"-> , password = def &= typ "PASSWORD" &= help "password"-> , title = def &= typ "TITLE" &= help "post title"-> , file = def &= argPos 0 &= typ "FILE"-> }-> &= program "BlogLiterately"-> &= summary ("BlogLierately v0.4, (c) Robert Greayer 2008-2010, Brent Yorgey 2012\n" ++-> "This program comes with ABSOLUTELY NO WARRANTY\n")--The main blogging function uses the information captured in the-`BlogLiterately` type to read the style preferences, read the input-file and transform it, and post it to the blog:--> blogLiterately bl@(BlogLiterately {..}) = do-> prefs <- getStylePrefs style-> let hsHighlight' = case hsHighlight of-> HsColourInline _ -> HsColourInline prefs-> _ -> hsHighlight-> bl' = bl { hsHighlight = hsHighlight' }-> html <- xformDoc bl' =<< U.readFile file-> postIt bl html--And the main program is simply:--> main = cmdArgs bl >>= blogLiterately--[markdown]: http://daringfireball.net/projects/markdown/-[pandoc]: http://johnmacfarlane.net/pandoc/ "Pandoc"-[hackage]: http://hackage.haskell.org/packages/hackage.html-[haddock]: http://www.haskell.org/haddock/-[hscolour]: http://www.cs.york.ac.uk/fp/darcs/hscolour/-[metaweblog]: http://www.xmlrpc.com/metaWeblogApi-[haxr]: http://www.haskell.org/haxr/-[hackage-haxr]: http://hackage.haskell.org/package/haxr-[cmdargs]: http://community.haskell.org/~ndm/cmdargs/-[haxml]: http://www.cs.york.ac.uk/fp/HaXml/
+ src/Text/BlogLiterately.hs view
@@ -0,0 +1,32 @@++-----------------------------------------------------------------------------+-- |+-- Module : Text.BlogLiterately+-- Copyright : (c) 2012 Brent Yorgey+-- License : GPL (see LICENSE)+-- Maintainer : Brent Yorgey <byorgey@gmail.com>+--+-- This module is provided as a convenient wrapper which re-exports+-- all the other @Text.BlogLiterately.*@ modules.+--+-----------------------------------------------------------------------------++module Text.BlogLiterately+ ( module Text.BlogLiterately.Block+ , module Text.BlogLiterately.Ghci+ , module Text.BlogLiterately.Highlight+ , module Text.BlogLiterately.Image+ , module Text.BlogLiterately.LaTeX+ , module Text.BlogLiterately.Options+ , module Text.BlogLiterately.Post+ , module Text.BlogLiterately.Transform+ ) where++import Text.BlogLiterately.Block+import Text.BlogLiterately.Ghci+import Text.BlogLiterately.Highlight+import Text.BlogLiterately.Image+import Text.BlogLiterately.LaTeX+import Text.BlogLiterately.Options+import Text.BlogLiterately.Post+import Text.BlogLiterately.Transform
+ src/Text/BlogLiterately/Block.hs view
@@ -0,0 +1,32 @@++-----------------------------------------------------------------------------+-- |+-- Module : Text.BlogLiterately.Block+-- Copyright : (c) 2008-2010 Robert Greayer, 2012 Brent Yorgey+-- License : GPL (see LICENSE)+-- Maintainer : Brent Yorgey <byorgey@gmail.com>+--+-- Utilities for working with code blocks.+--+-----------------------------------------------------------------------------++module Text.BlogLiterately.Block+ (+ unTag+ ) where++import Text.ParserCombinators.Parsec++-- | Given a block, if begins with a tag in square brackets, strip off+-- the tag and return a pair consisting of the tag and de-tagged+-- block. Otherwise, return @Nothing@ and the unchanged block.+unTag :: String -> (Maybe String, String)+unTag s = either (const (Nothing, s)) id $ parse tag "" s+ where+ tag = do+ tg <- between (char '[') (char ']') $ many $ noneOf "[]"+ skipMany $ oneOf " \t"+ (string "\r\n" <|> string "\n")+ txt <- many $ anyToken+ eof+ return (Just tg, txt)
+ src/Text/BlogLiterately/Ghci.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE PatternGuards #-}++-----------------------------------------------------------------------------+-- |+-- Module : Text.BlogLiterately.Ghci+-- Copyright : (c) 1997-2005 Ralf Hinze <ralf.hinze@comlab.ox.ac.uk>, Andres Loeh <lhs2tex@andres-loeh.de>, 2012 Brent Yorgey+-- License : GPL (see LICENSE)+-- Maintainer : Brent Yorgey <byorgey@gmail.com>+--+-- Format specially marked blocks as interactive ghci sessions. Uses+-- some ugly but effective code for interacting with an external ghci+-- process taken from lhs2TeX.+--+-----------------------------------------------------------------------------++module Text.BlogLiterately.Ghci+ (+ -- * Running ghci+ ProcessInfo+ , ghciEval+ , withGhciProcess+ , isLiterate+ , stopGhci++ -- * Extracting output+ -- $extract++ , magic+ , extract'+ , extract+ , breaks++ -- * Formatting+ , formatInlineGhci++ ) where++import Control.Arrow ( first)+import Control.Monad.IO.Class ( liftIO )+import Control.Monad.Trans.Reader ( ReaderT, runReaderT, ask )+import Data.Char ( isSpace )+import Data.Functor ( (<$>) )+import Data.List ( isPrefixOf, intercalate )+import System.IO+import System.Process ( ProcessHandle, waitForProcess+ , runInteractiveCommand )++import Data.List.Split+import Text.Pandoc ( Pandoc, Block(CodeBlock), bottomUpM )++import Text.BlogLiterately.Block ( unTag )++-- | Information about a running process: stdin, stdout, stderr, and a+-- handle.+type ProcessInfo = (Handle, Handle, Handle, ProcessHandle)++-- | An input to ghci consists of an expression/command, possibly+-- paired with an expected output.+data GhciInput = GhciInput { expr :: String, expected :: Maybe String }+ deriving Show++-- | An output from ghci is either a correct output, or an incorrect+-- (unexpected) output paired with the expected output.+data GhciOutput = OK String+ | Unexpected String String+ deriving Show++-- | A @GhciLine@ is a @GhciInput@ paired with its corresponding @GhciOutput@.+data GhciLine = GhciLine GhciInput GhciOutput+ deriving Show++-- | Evaluate an expression using an external @ghci@ process.+ghciEval :: GhciInput -> ReaderT ProcessInfo IO GhciOutput+ghciEval (GhciInput expr expected) = do+ (pin, pout, _, _) <- ask+ let script = "putStrLn " ++ show magic ++ "\n"+ ++ expr ++ "\n"+ ++ "putStrLn " ++ show magic ++ "\n"+ out <- liftIO $ do+ hPutStr pin script+ hFlush pin+ extract' pout+ let out' = strip out+ case expected of+ Nothing -> return $ OK out'+ Just exp+ | out' == exp -> return $ OK out'+ | otherwise -> return $ Unexpected out' exp++-- | Start an external ghci process, run a computation with access to+-- it, and finally stop the process.+withGhciProcess :: FilePath -> ReaderT ProcessInfo IO a -> IO a+withGhciProcess f m = do+ isLit <- isLiterate f+ pi <- runInteractiveCommand $ "ghci -v0 -ignore-dot-ghci "+ ++ (if isLit then f else "")+ res <- runReaderT m pi+ stopGhci pi+ return res++-- | Poor man's check to see whether we have a literate Haskell file.+isLiterate :: FilePath -> IO Bool+isLiterate f = (any ("> " `isPrefixOf`) . lines) <$> readFile f++-- | Stop a ghci process by passing it @:q@ and waiting for it to exit.+stopGhci :: ProcessInfo -> IO ()+stopGhci (pin,_,_,pid) = do+ hPutStrLn pin ":q"+ hFlush pin+ _ <- waitForProcess pid -- ignore exit code+ return ()++-- $extract+-- To extract the answer from @ghci@'s output we use a simple technique+-- which should work in most cases: we print the string @magic@ before+-- and after the expression we are interested in. We assume that+-- everything that appears before the first occurrence of @magic@ on the+-- same line is the prompt, and everything between the first @magic@ and+-- the second @magic@ plus prompt is the result we look for.++-- | There is nothing magic about the magic string.+magic :: String+magic = "!@#$^&*"++extract' :: Handle -> IO String+extract' h = fmap (extract . unlines) (readMagic 2)+ where+ readMagic :: Int -> IO [String]+ readMagic 0 = return []+ readMagic n = do+ l <- hGetLine h+ let n' | (null . snd . breaks (isPrefixOf magic)) l = n+ | otherwise = n - 1+ fmap (l:) (readMagic n')++extract :: String -> String+extract s = v+ where (t, u) = breaks (isPrefixOf magic) s+ -- t contains everything up to magic, u starts with magic+ -- |u' = tail (dropWhile (/='\n') u)|+ pre = reverse . takeWhile (/='\n') . reverse $ t+ prelength = if null pre then 0 else length pre + 1+ -- pre contains the prefix of magic on the same line+ u' = drop (length magic + prelength) u+ -- we drop the magic string, plus the newline, plus the prefix+ (v, _) = breaks (isPrefixOf (pre ++ magic)) u'+ -- we look for the next occurrence of prefix plus magic++breaks :: ([a] -> Bool) -> [a] -> ([a], [a])+breaks p [] = ([], [])+breaks p as@(a : as')+ | p as = ([], as)+ | otherwise = first (a:) $ breaks p as'++-- | Given the path to the @.lhs@ source and its representation as a+-- @Pandoc@ document, @formatInlineGhci@ finds any @[ghci]@ blocks+-- in it, runs them through @ghci@, and formats the results as an+-- interactive @ghci@ session.+--+-- Lines beginning in the first column of the block are interpreted+-- as inputs. Lines indented by one or more space are interpreted+-- as /expected outputs/. Consecutive indented lines are+-- interpreted as one multi-line expected output, with a number of+-- spaces removed from the beginning of each line equal to the+-- number of spaces at the start of the first indented line.+--+-- If the output for a given input is the same as the expected+-- output (or if no expected output is given), the result is typeset+-- normally. If the actual and expected outputs differ, the actual+-- output is typeset first in red, then the expected output in blue.+formatInlineGhci :: FilePath -> Pandoc -> IO Pandoc+formatInlineGhci f = withGhciProcess f . bottomUpM formatInlineGhci'+ where+ formatInlineGhci' :: Block -> ReaderT ProcessInfo IO Block+ formatInlineGhci' b@(CodeBlock attr s)+ | Just "ghci" <- tag = do+ results <- zipWith GhciLine inputs <$> mapM ghciEval inputs+ return $ CodeBlock attr (intercalate "\n" $ map formatGhciResult results)++ | otherwise = return b++ where (tag,src) = unTag s+ inputs = parseGhciInputs src++ formatInlineGhci' b = return b++parseGhciInputs :: String -> [GhciInput]+parseGhciInputs = map mkGhciInput+ . split+ ( dropInitBlank+ . dropFinalBlank+ . keepDelimsL+ $ whenElt (not . (" " `isPrefixOf`))+ )+ . lines++mkGhciInput :: [String] -> GhciInput+mkGhciInput [i] = GhciInput i Nothing+mkGhciInput (i:exp) = GhciInput i (Just . unlines' . unindent $ exp)++unlines' :: [String] -> String+unlines' = intercalate "\n"++strip :: String -> String+strip = f . f+ where f = dropWhile isSpace . reverse++unindent :: [String] -> [String]+unindent (x:xs) = map (drop indentAmt) (x:xs)+ where indentAmt = length . takeWhile (==' ') $ x++indent :: Int -> String -> String+indent n = unlines' . map (replicate n ' '++) . lines++colored color txt = "<span style=\"color: " ++ color ++ ";\">" ++ txt ++ "</span>"+coloredBlock color = unlines' . map (colored color) . lines++ghciPrompt = colored "gray" "ghci> "++formatGhciResult (GhciLine (GhciInput input _) (OK output))+ = ghciPrompt ++ input ++ "\n" ++ indent 2 output ++ "\n"+formatGhciResult (GhciLine (GhciInput input _) (Unexpected output exp))+ = ghciPrompt ++ input ++ "\n" ++ indent 2 (coloredBlock "red" output)+ ++ "\n" ++ indent 2 (coloredBlock "blue" exp)+ ++ "\n"++ -- XXX the styles above should be configurable...
+ src/Text/BlogLiterately/Highlight.hs view
@@ -0,0 +1,280 @@+{-# LANGUAGE DeriveDataTypeable #-}++-----------------------------------------------------------------------------+-- |+-- Module : Text.BlogLiterately.Highlight+-- Copyright : (c) 2008-2010 Robert Greayer, 2012 Brent Yorgey+-- License : GPL (see LICENSE)+-- Maintainer : Brent Yorgey <byorgey@gmail.com>+--+-- Syntax highlighting.+--+-----------------------------------------------------------------------------++module Text.BlogLiterately.Highlight+ ( HsHighlight(..)+ , colourIt+ , litify+ , StylePrefs+ , defaultStylePrefs+ , getStylePrefs+ , bakeStyles+ , replaceBreaks+ , colouriseCodeBlock+ , colourisePandoc+ ) where++import Control.Monad ( liftM )+import Data.Maybe ( isNothing )+import qualified System.IO.UTF8 as U ( readFile )++import Text.Pandoc ( Pandoc(..)+ , Block (CodeBlock, RawBlock) )+import Text.Pandoc.Highlighting ( highlight, formatHtmlBlock )+import Language.Haskell.HsColour ( hscolour, Output(..) )+import Language.Haskell.HsColour.Colourise ( defaultColourPrefs )+import System.Console.CmdArgs ( Data, Typeable )+import Text.XML.HaXml+import Text.XML.HaXml.Posn ( noPos )+import Text.Blaze.Html.Renderer.String ( renderHtml )++import Text.BlogLiterately.Block ( unTag )++-- | Four modes for highlighting Haskell.+data HsHighlight =+ HsColourInline StylePrefs -- ^ Use hscolour and inline the styles.+ | HsColourCSS -- ^ Use hscolour in conjunction with+ -- an external CSS style sheet.+ | HsKate -- ^ Use highlighting-kate.+ | HsNoHighlight -- ^ Do not highlight Haskell.+ deriving (Data,Typeable,Show,Eq)++{-++The literate Haskell that Pandoc finds in a file ends up in various+`CodeBlock` elements of the `Pandoc` document. Other code can also+wind up in `CodeBlock` elements -- normal markdown formatted code.+The `Attr` component has metadata about what's in the code block:++ [haskell]+ type Attr = ( String, -- code block identifier+ , [String] -- list of code classes+ , [(String, String)] -- name/value pairs+ )++Thanks to some feedback from the Pandoc author, John MacFarlane, I+learned that the CodeBlock *may* contain markers about the kind of+code contained within the block. LHS (bird-style or LaTex style) will+always have an `Attr` of the form `("",["sourceCode","haskell"],[])`,+and other `CodeBlock` elements are the markdown code blocks *may* have+an identifier, classes, or key/value pairs. Pandoc captures this info+when the file contains code blocks in the delimited (rather than+indented) format, which allows an optional meta-data specification,+e.g.++~~~~~~~~~~~+~~~~~~~ { .bash }+x=$1+echo $x+~~~~~~~+~~~~~~~~~~~++Although Pandoc supports the above format for marking code blocks (and+annotating the kind of code within the block) I'll also keep my+notation as another option for use with indented blocks, i.e. if you+write:++<pre><code>+ [haskell]+ foo :: String -> String+</code></pre>++it is a Haskell block. You can also use other annotations, *e.g.*++<pre><code>+ [cpp]+ cout << "Hello World!";+</code></pre>++If highlighting-kate is specified for highlighting Haskell blocks, the+distinction between the literate blocks and the delimited blocks is+lost (this is simply how the Pandoc highlighting module currently+works).++I'll adopt the rule that if you specify a class or classes using+Pandoc's delimited code block syntax, I'll assume that there is no+additional tag within the block in Blog Literately syntax. I still+need my `unTag` function to parse the code block.+++To highlight the syntax using hscolour (which produces HTML), I'm+going to need to transform the `String` from a `CodeBlock` element to+a `String` suitable for the `RawHtml` element (because the hscolour+library transforms Haskell text to HTML). Pandoc strips off the+prepended > characters from the literate Haskell, so I need to put+them back, and also tell hscolour whether the source it is colouring+is literate or not. The hscolour function looks like:++ [haskell]+ hscolour :: Output -- ^ Output format.+ -> ColourPrefs -- ^ Colour preferences...+ -> Bool -- ^ Whether to include anchors.+ -> Bool -- ^ Whether output document is partial or complete.+ -> String -- ^ Title for output.+ -> Bool -- ^ Whether input document is literate haskell+ -> String -- ^ Haskell source code.+ -> String -- ^ Coloured Haskell source code.++Since I still don't like the `ICSS` output from hscolour, I'm going to+provide two options for hscolouring to users: one that simply uses+hscolour's `CSS` format, so the user can provide definitions in their+blog's stylesheet to control the rendering, and a post-processing+option to transform the `CSS` class-based rendering into a inline+style based rendering (for people who can't update their stylesheet).+`colourIt` performs the initial transformation:++-}++-- | Use hscolour to syntax highlight some Haskell code. The first+-- argument indicates whether the code is literate Haskell.+colourIt :: Bool -> String -> String+colourIt literate srcTxt =+ hscolour CSS defaultColourPrefs False True "" literate srcTxt'+ where srcTxt' | literate = litify srcTxt+ | otherwise = srcTxt++-- | Prepend literate Haskell markers to some source code.+litify :: String -> String+litify = unlines . map ("> " ++) . lines++{-+Hscolour uses HTML `span` elements and CSS classes like 'hs-keyword'+or `hs-keyglyph` to markup Haskell code. What I want to do is take+each marked `span` element and replace the `class` attribute with an+inline `style` element that has the markup I want for that kind of+source. Style preferences are specified as a list of name/value+pairs:+-}++-- | Style preferences are specified as a list of mappings from class+-- attributes to CSS style attributes.+type StylePrefs = [(String,String)]++-- | A default style that produces something that looks like the+-- source listings on Hackage.+defaultStylePrefs :: StylePrefs+defaultStylePrefs =+ [ ("hs-keyword","color: blue; font-weight: bold;")+ , ("hs-keyglyph","color: red;")+ , ("hs-layout","color: red;")+ , ("hs-comment","color: green;")+ , ("hs-conid", "")+ , ("hs-varid", "")+ , ("hs-conop", "")+ , ("hs-varop", "")+ , ("hs-str", "color: teal;")+ , ("hs-chr", "color: teal;")+ , ("hs-number", "")+ , ("hs-cpp", "")+ , ("hs-selection", "")+ , ("hs-variantselection", "")+ , ("hs-definition", "")+ ]++-- | Read style preferences in from a file using the @Read@ instance+-- for @StylePrefs@, or return the default style if the file name is+-- empty.+getStylePrefs :: FilePath -> IO StylePrefs+getStylePrefs "" = return defaultStylePrefs+getStylePrefs fname = liftM read (U.readFile fname)++-- | Take a @String@ of HTML produced by hscolour, and \"bake\" styles+-- into it by replacing class attributes with appropriate style+-- attributes.+bakeStyles :: StylePrefs -> String -> String+bakeStyles prefs s = verbatim $ filtDoc (xmlParse "bake-input" s)+ where++ -- filter the document (an Hscoloured fragment of Haskell source)+ filtDoc (Document p s e m) = c where+ [c] = filts (CElem e noPos)++ -- the filter is a fold of individual filters for each CSS class+ filts = mkElem "pre" [(foldXml $ foldl o keep $ map filt prefs) `o` replaceTag "code"]++ -- an individual filter replaces the attributes of a tag with+ -- a style attribute when it has a specific 'class' attribute.+ filt (cls,style) =+ replaceAttrs [("style",style)] `when`+ (attrval $ (N "class", AttValue [Left cls]))++{- Highlighting-Kate uses @\<br/>@ in code blocks to indicate+ newlines. WordPress (and possibly others) chooses to strip them+ away when found in @\<pre>@ sections of uploaded HTML. So we+ need to turn them back to newlines.+-}++-- | Replace @\<br/>@ tags with newlines.+replaceBreaks :: String -> String+replaceBreaks s = verbatim $ filtDoc (xmlParse "input" s)+ where+ -- filter the document (a highlighting-kate highlighted fragment of+ -- haskell source)+ filtDoc (Document p s e m) = c where+ [c] = filts (CElem e noPos)+ filts = foldXml (literal "\n" `when` tag "br")++{-+Note/todo: the above is a function that could be made better in a+few ways and then factored out into a library. A way to handle the+above would be to allow the preferences to be specified as an actual+CSS style sheet, which then would be baked into the HTML. Such a+function could be separately useful, and could be used to 'bake' in+the highlighting-kate styles.+-}++-- | Transform a @CodeBlock@ into a @RawHtml@ block, where+-- the content contains marked up Haskell (possibly with literate+-- markers), or marked up non-Haskell, if highlighting of non-Haskell has+-- been selected.+colouriseCodeBlock :: HsHighlight -> Bool -> Block -> Block+colouriseCodeBlock hsHighlight otherHighlight b@(CodeBlock attr@(_,classes,_) s)++ | tag == Just "haskell" || haskell+ = case hsHighlight of+ HsColourInline style ->+ RawBlock "html" $ bakeStyles style $ colourIt lit src+ HsColourCSS -> RawBlock "html" $ colourIt lit src+ HsNoHighlight -> RawBlock "html" $ simpleHTML hsrc+ HsKate -> case tag of+ Nothing -> myHighlightK attr hsrc+ Just t -> myHighlightK ("", t:classes,[]) hsrc++ | otherHighlight+ = case tag of+ Nothing -> myHighlightK attr src+ Just t -> myHighlightK ("",[t],[]) src++ | otherwise+ = RawBlock "html" $ simpleHTML src++ where+ (tag,src)+ | null classes = unTag s+ | otherwise = (Nothing, s)+ hsrc+ | lit = litify src+ | otherwise = src+ lit = "sourceCode" `elem` classes+ haskell = "haskell" `elem` classes+ simpleHTML s = "<pre><code>" ++ s ++ "</code></pre>"+ myHighlightK attr s = case highlight formatHtmlBlock attr s of+ Nothing -> RawBlock "html" $ simpleHTML s+ Just html -> RawBlock "html" $ replaceBreaks $ renderHtml html++colouriseCodeBlock _ _ b = b++-- | Perform syntax highlighting on an entire Pandoc document.+colourisePandoc :: HsHighlight -> Bool -> Pandoc -> Pandoc+colourisePandoc hsHighlight otherHighlight (Pandoc m blocks) =+ Pandoc m $ map (colouriseCodeBlock hsHighlight otherHighlight) blocks
+ src/Text/BlogLiterately/Image.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE RecordWildCards #-}++-----------------------------------------------------------------------------+-- |+-- Module : Text.BlogLiterately.Image+-- Copyright : (c) 2012 Brent Yorgey+-- License : GPL (see LICENSE)+-- Maintainer : Brent Yorgey <byorgey@gmail.com>+--+-- Uploading images embedded in posts to the server.+--+-----------------------------------------------------------------------------++module Text.BlogLiterately.Image+ (+ uploadAllImages+ , uploadIt+ , mkMediaObject+ ) where++import Control.Arrow ( first, (>>>), arr+ , Kleisli(..), runKleisli )+import qualified Control.Category as C ( Category, id )+import Control.Monad ( liftM, unless )+import Control.Monad.IO.Class ( liftIO )+import Control.Monad.Trans.Reader ( ReaderT, runReaderT, ask )+import qualified Data.ByteString.Char8 as B+import Data.Char ( toLower )+import Data.Functor ( (<$>) )+import Data.List ( isPrefixOf, intercalate )+import Data.Maybe ( fromMaybe )+import System.Directory ( doesFileExist )+import System.FilePath ( takeFileName, takeExtension )+import System.IO+import qualified System.IO.UTF8 as U ( readFile )+import System.Process ( ProcessHandle, waitForProcess+ , runInteractiveCommand )+import Text.Pandoc+import Network.XmlRpc.Client ( remote )+import Network.XmlRpc.Internals ( Value(..), toValue )++import Text.BlogLiterately.Options++-- | Transform a document by uploading any \"local\" images to the+-- server, and replacing their filenames with the URLs returned by the+-- server.+uploadAllImages :: BlogLiterately -> (Pandoc -> IO Pandoc)+uploadAllImages bl@(BlogLiterately{..}) =+ case blog of+ Just xmlrpc -> bottomUpM (uploadOneImage xmlrpc)+ _ -> return+ where+ uploadOneImage :: String -> Inline -> IO Inline+ uploadOneImage xmlrpc i@(Image altText (imgUrl, imgTitle))+ | isLocal imgUrl = do+ res <- uploadIt xmlrpc imgUrl bl+ case res of+ Just (ValueStruct (lookup "url" -> Just (ValueString newUrl))) ->+ return $ Image altText (newUrl, imgTitle)+ _ -> do+ putStrLn $ "Warning: upload of " ++ imgUrl ++ " failed."+ return i+ | otherwise = return i+ uploadOneImage _ i = return i++ isLocal imgUrl = none (`isPrefixOf` imgUrl) ["http", "/"]+ none p = all (not . p)++-- | Upload a file using the @metaWeblog.newMediaObject@ XML-RPC method+-- call.+uploadIt :: String -> FilePath -> BlogLiterately -> IO (Maybe Value)+uploadIt url filePath (BlogLiterately{..}) = do+ putStr $ "Uploading " ++ filePath ++ "..."+ mmedia <- mkMediaObject filePath+ case mmedia of+ Nothing -> do+ putStrLn $ "\nFile not found: " ++ filePath+ return Nothing+ Just media -> do+ val <- remote url "metaWeblog.newMediaObject" blogid user (fromMaybe "" password) media+ putStrLn "done."+ return $ Just val++-- | Prepare a file for upload.+mkMediaObject :: FilePath -> IO (Maybe Value)+mkMediaObject filePath = do+ exists <- doesFileExist filePath+ if not exists+ then return Nothing+ else do+ bits <- B.readFile filePath+ return . Just $ ValueStruct+ [ ("name", toValue fileName)+ , ("type", toValue fileType)+ , ("bits", ValueBase64 bits)+ ]+ where+ fileName = takeFileName filePath+ fileType = case (map toLower . drop 1 . takeExtension) fileName of+ "png" -> "image/png"+ "jpg" -> "image/jpeg"+ "jpeg" -> "image/jpeg"+ "gif" -> "image/gif"
+ src/Text/BlogLiterately/LaTeX.hs view
@@ -0,0 +1,41 @@++-----------------------------------------------------------------------------+-- |+-- Module : Text.BlogLiterately.LaTeX+-- Copyright : (c) 2012 Brent Yorgey+-- License : GPL (see LICENSE)+-- Maintainer : Brent Yorgey <byorgey@gmail.com>+--+-- Utilities for working with embedded LaTeX.+--+-----------------------------------------------------------------------------++module Text.BlogLiterately.LaTeX+ (+ wpTeXify+ ) where++import Data.List ( isPrefixOf )+import Text.Pandoc++-- | WordPress can render LaTeX, but expects it in a special non-standard+-- format (@\$latex foo\$@). The @wpTeXify@ function formats LaTeX code+-- using this format so that it can be processed by WordPress.+wpTeXify :: Pandoc -> Pandoc+wpTeXify = bottomUp formatDisplayTex . bottomUp formatInlineTex+ where formatInlineTex :: [Inline] -> [Inline]+ formatInlineTex (Math InlineMath tex : is)+ = (Str $ "$latex " ++ unPrefix "latex" tex ++ "$") : is+ formatInlineTex is = is++ formatDisplayTex :: [Block] -> [Block]+ formatDisplayTex (Para [Math DisplayMath tex] : bs)+ = RawBlock "html" "<p><div style=\"text-align: center\">"+ : Plain [Str $ "$latex " ++ "\\displaystyle " ++ unPrefix "latex" tex ++ "$"]+ : RawBlock "html" "</div></p>"+ : bs+ formatDisplayTex bs = bs++ unPrefix pre s+ | pre `isPrefixOf` s = drop (length pre) s+ | otherwise = s
+ src/Text/BlogLiterately/Options.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE DeriveDataTypeable #-}++-----------------------------------------------------------------------------+-- |+-- Module : Text.BlogLiterately.Options+-- Copyright : (c) 2008-2010 Robert Greayer, 2012 Brent Yorgey+-- License : GPL (see LICENSE)+-- Maintainer : Brent Yorgey <byorgey@gmail.com>+--+-- Configuation and command-line options.+--+-----------------------------------------------------------------------------++module Text.BlogLiterately.Options+ ( BlogLiterately(..)+ , blOpts+ )+ where++import System.Console.CmdArgs++import Text.BlogLiterately.Highlight++-- | Configuration record (and command-line options) for @BlogLiterately@.+data BlogLiterately = BlogLiterately+ { style :: String -- ^ Name of a style file+ , hsHighlight :: HsHighlight -- ^ Haskell highlighting mode+ , otherHighlight :: Bool -- ^ Use highlighting-kate for+ -- non-Haskell?+ , wplatex :: Bool -- ^ Format LaTeX for WordPress?+ , ghci :: Bool -- ^ Automatically process ghci sessions?+ , uploadImages :: Bool -- ^ Automatically upload images?+ , categories :: [String] -- ^ Categories for the post+ , tags :: [String] -- ^ Tags for the post+ , blogid :: String -- ^ Blog-specific identifier+ -- (e.g. for blogging software+ -- handling multiple blogs)+ , blog :: Maybe String -- ^ Blog xmlrpc URL+ , user :: String -- ^ Blog user name+ , password :: Maybe String -- ^ Blog password (omit to be interactively prompted)+ , title :: String -- ^ Post title+ , file :: String -- ^ File to post+ , postid :: Maybe String -- ^ ID of a post to update+ , page :: Bool -- ^ Create a \"page\" instead of a post+ , publish :: Bool -- ^ Should the post be published?+ -- (Otherwise it is uploaded as a draft.)+ , xtra :: [String] -- ^ Extension arguments, for use e.g. by+ -- custom transforms+ }+ deriving (Show,Data,Typeable)++-- | Command-line configuration for use with @cmdargs@.+blOpts :: BlogLiterately+blOpts = BlogLiterately+ { style = "" &= help "style specification (for --hscolour-icss)"+ &= typFile+ , hsHighlight = enum+ [ (HsColourInline defaultStylePrefs)+ &= explicit+ &= name "hscolour-icss"+ &= help "highlight haskell: hscolour, inline style (default)"+ , HsColourCSS+ &= explicit+ &= name "hscolour-css"+ &= help "highlight haskell: hscolour, separate stylesheet"+ , HsNoHighlight+ &= explicit+ &= name "hs-nohighlight"+ &= help "no haskell highlighting"+ , HsKate+ &= explicit+ &= name "hs-kate"+ &= help "highlight haskell with highlighting-kate"+ ]+ , otherHighlight = enum+ [ True+ &= explicit+ &= name "other-kate"+ &= help "highlight other code with highlighting-kate"+ ]+ , wplatex = def &= help "reformat inline LaTeX the way WordPress expects"+ , ghci = def &= help "run [ghci] blocks through ghci and include output"+ , uploadImages = def &= name "upload-images" &= explicit &= help "upload local images"+ , page = def &= help "create a \"page\" instead of a post (WordPress only)"+ , publish = def &= help "publish post (otherwise it's uploaded as a draft)"+ , categories = def+ &= explicit+ &= name "category"+ &= help "post category (can specify more than one)"+ , tags = def+ &= explicit+ &= name "tag"+ &= help "tag (can specify more than one)"++ , xtra = def+ &= help "extension arguments, for use with custom extensions"+ , blogid = "default" &= help "Blog specific identifier" &= typ "ID"+ , postid = def &= help "Post to replace (if any)" &= typ "ID"++ , blog = def &= typ "URL" &= help "blog XML-RPC url (if omitted, html goes to stdout)"+ , user = def &= typ "USER" &= help "user name"+ , password = def &= typ "PASSWORD" &= help "password"+ , title = def &= typ "TITLE" &= help "post title"+ , file = def &= argPos 0 &= typ "FILE"+ }+ &= program "BlogLiterately"+ &= summary ("BlogLierately v0.4, (c) Robert Greayer 2008-2010, Brent Yorgey 2012\n" +++ "This program comes with ABSOLUTELY NO WARRANTY\n")
+ src/Text/BlogLiterately/Post.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleContexts #-}++-----------------------------------------------------------------------------+-- |+-- Module : Text.BlogLiterately.Post+-- Copyright : (c) 2008-2010 Robert Greayer, 2012 Brent Yorgey+-- License : GPL (see LICENSE)+-- Maintainer : Brent Yorgey <byorgey@gmail.com>+--+-- Uploading posts to the server.+--+-----------------------------------------------------------------------------++module Text.BlogLiterately.Post+ (+ mkPost, mkArray, postIt+ ) where++import Control.Monad ( unless )+import Data.Maybe ( fromMaybe )++import Network.XmlRpc.Client ( remote )+import Network.XmlRpc.Internals ( Value(..), toValue, XmlRpcType )++import Text.BlogLiterately.Options++{-+The metaWeblog API defines `newPost` and `editPost` procedures that+look like:++ [other]+ metaWeblog.newPost (blogid, username, password, struct, publish)+ returns string+ metaWeblog.editPost (postid, username, password, struct, publish)+ returns true++For WordPress blogs, the `blogid` is ignored. The user name and+password are simply strings, and `publish` is a flag indicating+whether to load the post as a draft, or to make it public immediately.+The `postid` is an identifier string which is assigned when you+initially create a post. The interesting bit is the `struct` field,+which is an XML-RPC structure defining the post along with some+meta-data, like the title. I want be able to provide the post body, a+title, and lists of categories and tags. For the body and title, we+could just let HaXR convert the values automatically into the XML-RPC+`Value` type, since they all have the same Haskell type (`String`) and+thus can be put into a list. But the categories and tags are lists of+strings, so we need to explicitly convert everything to a `Value`,+then combine:+-}++-- | Prepare a post for uploading by creating something of the proper+-- form to be an argument to an XML-RPC call.+mkPost :: String -- ^ Post title+ -> String -- ^ Post content+ -> [String] -- ^ List of categories+ -> [String] -- ^ List of tags+ -> Bool -- ^ @True@ = page, @False@ = post+ -> [(String, Value)]+mkPost title text categories tags page =+ mkArray "categories" categories+ ++ mkArray "mt_keywords" tags+ ++ [ ("title", toValue title)+ , ("description", toValue text)+ ]+ ++ [ ("post_type", toValue "page") | page ]++-- | Given a name and a list of values, create a named \"array\" field+-- suitable for inclusion in an XML-RPC struct.+mkArray :: XmlRpcType [a] => String -> [a] -> [(String, Value)]+mkArray _ [] = []+mkArray name values = [(name, toValue values)]++{-+The HaXR library exports a function for invoking XML-RPC procedures:++ [haskell]+ remote :: Remote a =>+ String -- ^ Server URL. May contain username and password on+ -- the format username:password\@ before the hostname.+ -> String -- ^ Remote method name.+ -> a -- ^ Any function+ -- @(XmlRpcType t1, ..., XmlRpcType tn, XmlRpcType r) =>+ -- t1 -> ... -> tn -> IO r@++The function requires an URL and a method name, and returns a function+of type `Remote a => a`. Based on the instances defined for `Remote`,+any function with zero or more parameters in the class `XmlRpcType`+and a return type of `XmlRpcType r => IO r` will work, which means you+can simply 'feed' `remote` additional arguments as required by the+remote procedure, and as long as you make the call in an IO context,+it will typecheck. `postIt` calls `metaWeblog.newPost` or+`metaWeblog.editPost` (or simply prints the HTML to stdout) as+appropriate:+-}++-- | Given a configuration and a formatted post, upload it to the server.+postIt :: BlogLiterately -> String -> IO ()+postIt (BlogLiterately{..}) html =+ case blog of+ Nothing -> putStr html+ Just url -> do+ let pwd = fromMaybe "" password+ case postid of+ Nothing -> do+ pid <- remote url "metaWeblog.newPost" blogid user pwd+ (mkPost title html categories tags page) publish+ putStrLn $ "Post ID: " ++ pid+ Just pid -> do+ success <- remote url "metaWeblog.editPost" pid user pwd+ (mkPost title html categories tags page) publish+ unless success $ putStrLn "update failed!"+
+ src/Text/BlogLiterately/Run.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE RecordWildCards #-}++-----------------------------------------------------------------------------+-- |+-- Module : Text.BlogLiterately.Run+-- Copyright : (c) 2012 Brent Yorgey+-- License : GPL (see LICENSE)+-- Maintainer : Brent Yorgey <byorgey@gmail.com>+--+-- Functions for creating @BlogLiterately@ executables. By default,+-- installing this library results in the installation of a standard+-- executable, called @BlogLiterately@, which corresponds to+-- 'blogLiterately' from this module. However, you can create your+-- own custom executables with extra custom functionality using+-- 'blogLiteratelyWith' or 'blogLiteratelyCustom'. For example:+--+-- > module Main where+-- > myCustomXF = Transform ...+-- > main = blogLiteratelyWith [myCustomXF]+--+-- See "Text.BlogLiterately.Transform" for examples of transforms and+-- help in creating your own.+--+-----------------------------------------------------------------------------++module Text.BlogLiterately.Run+ (+ blogLiterately+ , blogLiteratelyWith+ , blogLiteratelyCustom++ ) where++import System.Console.CmdArgs ( cmdArgs)+import System.IO ( hFlush, stdout )+import qualified System.IO.UTF8 as U ( readFile )++import Text.BlogLiterately.Highlight+import Text.BlogLiterately.Options+import Text.BlogLiterately.Post+import Text.BlogLiterately.Transform++-- | The default BlogLiterately application.+blogLiterately :: IO ()+blogLiterately = blogLiteratelyCustom standardTransforms++-- | Like 'blogLiterately', but with the ability to specify custom+-- 'Transform's which will be applied /after/ the standard ones.+blogLiteratelyWith :: [Transform] -> IO ()+blogLiteratelyWith ts = blogLiteratelyCustom (standardTransforms ++ ts)++-- | Like 'blogLiterately', but with the ability to /replace/ the+-- standard 'Transform's with your own. Use this to implement+-- custom interleaving orders of the standard transforms and your+-- own, to exclude some or all of the standard transforms, etc.+blogLiteratelyCustom :: [Transform] -> IO ()+blogLiteratelyCustom ts = do+ bl <- cmdArgs blOpts+ let (BlogLiterately{..}) = bl++ prefs <- getStylePrefs style+ let hsHighlight' = case hsHighlight of+ HsColourInline _ -> HsColourInline prefs+ _ -> hsHighlight+ bl' = bl { hsHighlight = hsHighlight' }++ pwd <- case (blog, password) of+ (Just _, Nothing) -> passwordPrompt+ _ -> return password+ let bl'' = bl' { password = pwd }++ html <- xformDoc bl'' ts =<< U.readFile file+ postIt bl'' html++passwordPrompt :: IO (Maybe String)+passwordPrompt = do+ putStr "Password: " >> hFlush stdout+ pwd <- getLine+ return $ Just pwd
+ src/Text/BlogLiterately/Transform.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeOperators #-}++-----------------------------------------------------------------------------+-- |+-- Module : Text.BlogLiterately.Transform+-- Copyright : (c) 2008-2010 Robert Greayer, 2012 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.+--+-----------------------------------------------------------------------------++module Text.BlogLiterately.Transform+ ( -- * Transforms+ Transform(..), runTransform, runTransforms++ -- * Standard transforms+ , wptexifyXF+ , ghciXF+ , imagesXF+ , highlightXF+ , standardTransforms++ -- * Transforming documents+ , xformDoc++ -- * Utilities+ , 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 Text.Pandoc+import Text.Blaze.Html.Renderer.String ( renderHtml )++import Text.BlogLiterately.Ghci+import Text.BlogLiterately.Highlight+import Text.BlogLiterately.Image+import Text.BlogLiterately.LaTeX+import Text.BlogLiterately.Options++-- | 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 @'Kleisli' IO 'Pandoc'+-- 'Pandoc'@ arrow, which is isomorphic to @Pandoc -> IO Pandoc@. If+-- you have a pure function of type @Pandoc -> Pandoc@, wrap it in a+-- call to 'arr' to produce a 'Kleisli' arrow. If you have a+-- function @Pandoc -> IO Pandoc@, wrap it in the 'Kleisli'+-- constructor.+--+-- For examples, see the implementations of the standard transforms+-- below.+data Transform = Transform+ { getTransform :: BlogLiterately -> Kleisli IO Pandoc Pandoc+ -- ^ A document transformation, which can depend on+ -- BlogLiterately options and can have effects in+ -- the @IO@ monad.+ , xfCond :: BlogLiterately -> Bool+ -- ^ A condition under which to run the transformation.+ }++-- | Run a 'Transform' (if its condition is met).+runTransform :: Transform -> BlogLiterately -> Kleisli IO Pandoc Pandoc+runTransform t bl = getTransform t bl `whenA` xfCond t bl++-- | Run a pipeline of 'Transform's.+runTransforms :: [Transform] -> BlogLiterately -> Kleisli IO Pandoc Pandoc+runTransforms ts = foldr (>>>) (C.id) . T.traverse runTransform ts++-- | Format embedded LaTeX for WordPress (if the @wplatex@ flag is set).+wptexifyXF :: Transform+wptexifyXF = Transform (const (arr wpTeXify)) wplatex++-- | Format embedded @ghci@ sessions (if the @ghci@ flag is set).+ghciXF :: Transform+ghciXF = Transform (Kleisli . formatInlineGhci . file) ghci++-- | Upload embedded local images to the server (if the @uploadImages@+-- flag is set).+imagesXF :: Transform+imagesXF = Transform (Kleisli . uploadAllImages) uploadImages++-- | Perform syntax highlighting on code blocks.+highlightXF :: Transform+highlightXF = Transform+ (\bl -> arr (colourisePandoc (hsHighlight bl) (otherHighlight bl)))+ (const True)++-- | The standard set of transforms that are run by default:+-- 'wptexifyXF', 'ghciXF', 'imagesXF', 'highlightXF'.+standardTransforms :: [Transform]+standardTransforms = [wptexifyXF, ghciXF, imagesXF, highlightXF]++-- | Transform a complete input document string to an HTML output+-- string, given a list of transformation passes.+xformDoc :: BlogLiterately -> [Transform] -> (String -> IO String)+xformDoc bl xforms = runKleisli $+ arr fixLineEndings+ >>> arr (readMarkdown parseOpts)++ >>> runTransforms xforms bl++ >>> arr (writeHtml writeOpts)+ >>> arr renderHtml+ where+ writeOpts = defaultWriterOptions+ { writerReferenceLinks = True }+ parseOpts = defaultParserState+ { stateLiterateHaskell = True }++-- | Turn @CRLF@ pairs into a single @LF@. This is necessary since+-- 'readMarkdown' is picky about line endings.+fixLineEndings :: String -> String+fixLineEndings [] = []+fixLineEndings ('\r':'\n':cs) = '\n':fixLineEndings cs+fixLineEndings (c:cs) = c:fixLineEndings cs++-- | A useful arrow utility for running some part of a pipeline+-- conditionally.+whenA :: C.Category (~>) => (a ~> a) -> Bool -> (a ~> a)+whenA a p | p = a+ | otherwise = C.id