BlogLiterately 0.5.4.1 → 0.6
raw patch · 14 files changed
+1025/−391 lines, 14 filesdep +highlighting-katedep +lensdep +mtldep ~pandoc
Dependencies added: highlighting-kate, lens, mtl, pandoc-types
Dependency ranges changed: pandoc
Files
- BlogLiterately.cabal +14/−8
- CHANGES +0/−87
- CHANGES.md +117/−0
- README.markdown +12/−0
- doc/BlogLiteratelyDoc.lhs +158/−45
- src/Text/BlogLiterately/Block.hs +19/−1
- src/Text/BlogLiterately/Ghci.hs +19/−22
- src/Text/BlogLiterately/Highlight.hs +64/−20
- src/Text/BlogLiterately/Image.hs +30/−25
- src/Text/BlogLiterately/Options.hs +220/−62
- src/Text/BlogLiterately/Options/Parse.hs +89/−0
- src/Text/BlogLiterately/Post.hs +30/−17
- src/Text/BlogLiterately/Run.hs +19/−35
- src/Text/BlogLiterately/Transform.hs +234/−69
BlogLiterately.cabal view
@@ -1,5 +1,5 @@ Name: BlogLiterately-Version: 0.5.4.1+Version: 0.6 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@@ -20,21 +20,22 @@ License: GPL License-file: LICENSE Category: Web-Copyright: Copyright (c) Robert Greayer 2008-2010, Brent Yorgey 2012+Copyright: Copyright (c) Robert Greayer 2008-2010, Brent Yorgey 2012-2013 Author: Robert Greayer <robgreayer@yahoo.com> Maintainer: Brent Yorgey <byorgey@cis.upenn.edu> Stability: experimental Build-Type: Simple Tested-With: GHC ==7.4.2, GHC ==7.6.1-Extra-Source-Files: CHANGES+Extra-Source-Files: CHANGES.md+ README.markdown doc/BlogLiteratelyDoc.lhs style/*.css style/hs-style-Bug-reports: http://hub.darcs.net/byorgey/BlogLiterately/issues+Bug-reports: http://github.com/byorgey/BlogLiterately/issues Source-repository head- type: darcs- location: http://hub.darcs.net/byorgey/BlogLiterately+ type: git+ location: git://github.com/byorgey/BlogLiterately.git Library Build-Depends: base >= 4.0 && < 4.7,@@ -44,6 +45,7 @@ bytestring, containers, bool-extras,+ mtl, split >= 0.1.4 && < 0.3, utf8-string >= 0.3 && < 0.4, transformers >= 0.3 && < 0.4,@@ -53,8 +55,11 @@ blaze-html >= 0.5 && < 0.7, cmdargs >= 0.9.5 && < 0.11, haxr >= 3000.9 && < 3000.10,- pandoc >= 1.10 && < 1.11,- data-default >= 0.5 && < 0.6+ pandoc >= 1.10 && < 1.12,+ pandoc-types >= 1.10 && < 1.11,+ highlighting-kate >= 0.5 && < 0.6,+ data-default >= 0.5 && < 0.6,+ lens >= 3.8 && < 3.9 Exposed-modules: Text.BlogLiterately Text.BlogLiterately.Block Text.BlogLiterately.Ghci@@ -62,6 +67,7 @@ Text.BlogLiterately.Image Text.BlogLiterately.LaTeX Text.BlogLiterately.Options+ Text.BlogLiterately.Options.Parse Text.BlogLiterately.Post Text.BlogLiterately.Run Text.BlogLiterately.Transform
− CHANGES
@@ -1,87 +0,0 @@-0.5.4.1: 18 February 2013-- * bump blaze-html upper bound to < 0.7--0.5.4: 24 January 2013-- * Require pandoc 1.10.--0.5.3: 19 November 2012-- * New --math option for selecting pandoc math writing mode-- * Run the pandoc parser in "smart" mode, which generates proper en-- and em-dashes, quotation marks, etc.-- * More updates for GHC 7.6.1 compatibility-- * Using highlighting-kate to highlight non-Haskell code was already- the default; make this more clear.-- The --other-kate option is no more; now there are two options-- --kate- --no-kate-- with --kate the default.--0.5.2.1: 19 September 2012-- * bump base upper bound to <4.7--0.5.2: 20 August 2012-- * improvement to behavior of --upload-images flag: cache uploaded- image server URLs, even across multiple runs, to avoid uploading- the same image multiple times-- * bump dep upper bounds:- - split to < 0.3- - cmdargs to < 0.11--0.5.1: 30 July 2012-- * Escape < and > characters in ghci output-- * Supress vertical whitespace following ghci commands that produce- no output-- * add centerImagesXF transform (disabled by default)-- * create bug tracker and add Bug-reports: field to .cabal file-- * re-export Text.BlogLiterately.Run from Text.BlogLiterately-- * improved documentation-- * fix output of --version--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-- * Support for [ghci] blocks with contents automatically passed- through ghci and results typeset-- * Support for tags-- * Support for creating "pages" as well as posts (WordPress only)-- * New standalone documentation-- * Code cleanup-- * Update to build with GHC 7.4.1
+ CHANGES.md view
@@ -0,0 +1,117 @@+0.6: 10 March 2013+------------------++ * Add support for "profiles" with sets of common options++ * Add support for reading options from inline blocks tagged `[BLOpts]`++ * Add support for reading post titles using pandoc-supported title+ block format, `% Title`++ * Transforms are now of type StateT (BlogLiterately, Pandoc) IO (),+ to allow transforms to alter the options record as well as the+ document++ * Add `centerImagesXF` to standard transforms++ * Move a bunch of ad-hoc functionality into standard transforms++ * Add `--html-only` option++ * bump `pandoc` upper bound to < 1.12++0.5.4.1: 18 February 2013+-------------------------++ * bump `blaze-html` upper bound to < 0.7++0.5.4: 24 January 2013+----------------------++ * Require `pandoc` 1.10.++0.5.3: 19 November 2012+-----------------------++ * New `--math` option for selecting pandoc math writing mode++ * Run the pandoc parser in "smart" mode, which generates proper en-+ and em-dashes, quotation marks, etc.++ * More updates for GHC 7.6.1 compatibility++ * Using `highlighting-kate` to highlight non-Haskell code was already+ the default; make this more clear.++ The `--other-kate` option is no more; now there are two options++ `--kate`+ `--no-kate`++ with `--kate` the default.++0.5.2.1: 19 September 2012+--------------------------++ * bump `base` upper bound to <4.7++0.5.2: 20 August 2012+---------------------++ * improvement to behavior of `--upload-images` flag: cache uploaded+ image server URLs, even across multiple runs, to avoid uploading+ the same image multiple times++ * bump dep upper bounds:+ - `split` to < 0.3+ - `cmdargs` to < 0.11++0.5.1: 30 July 2012+-------------------++ * Escape `<` and `>` characters in `ghci` output++ * Supress vertical whitespace following `ghci` commands that produce+ no output++ * add `centerImagesXF` transform (disabled by default)++ * create bug tracker and add `Bug-reports:` field to `.cabal` file++ * re-export `Text.BlogLiterately.Run` from `Text.BlogLiterately`++ * improved documentation++ * fix output of `--version`++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++ * Support for `[ghci]` blocks with contents automatically passed+ through `ghci` and results typeset++ * Support for tags++ * Support for creating "pages" as well as posts (WordPress only)++ * New standalone documentation++ * Code cleanup++ * Update to build with GHC 7.4.1
+ README.markdown view
@@ -0,0 +1,12 @@+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).++To get started, use the provided executable `BlogLiterately`; see+[http://byorgey.wordpress.com/blogliterately/](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`](http://hackage.haskell.org/packages/archive/BlogLiterately/latest/doc/html/Text-BlogLiterately-Run.html).
doc/BlogLiteratelyDoc.lhs view
@@ -1,3 +1,11 @@+ [BLOpts]+ profile = wp+ postid = 802+ title = BlogLiterately+ ghci = true+ wplatex = true+ page = true+ [`BlogLiterately`][] is a tool for uploading blog posts to servers that support the [MetaWeblog API][metaweblog] (such as [WordPress][]-based blogs and many others). Blog posts to be@@ -11,10 +19,45 @@ no code at all. `BlogLiterately` includes support for syntax highlighting, $\LaTeX$-(including special support for WordPress blogs), and automatic-generation and formatting of `ghci` sessions. Each of these features-is explained in more detail below.+(including special support for WordPress blogs), automatic image+uploading, and automatic generation and formatting of `ghci` sessions.+Each of these features is explained in more detail below. +Example usage+-------------++If you do not specify a blog URL, by default `BlogLiterately` simply+prints the generated HTML to stdout. So, to preview the generated+HTML before uploading requires merely something like++ BlogLiterately Sample.lhs++To actually post to, say, a WordPress blog, a basic command line would+be something like++ BlogLiterately --blog http://blogurl.example.com/xmlrpc.php \+ --user myname --password mypasswd --title "Sample" Sample.lhs++(which creates a new post). You can also omit the `--password` option,+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. 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).++The above examples only show the most basic usage. In particular, the+pain of constructing long command lines like the above is unnecessary,+and can be replaced by the use of profiles and embedding options+within the source file itself; these features are explained below.+ Markdown and pandoc ------------------- @@ -74,7 +117,7 @@ using "inline" CSS style attributes. The default styling is similar to that used for source code in documentation on [Hackage][]. You can also specify a configuration file containing a Haskell value of type-[(String,String)] which specifies a CSS style for each syntax+`[(String,String)]` which specifies a CSS style for each syntax class. An example (corresponding to the default configuration) is provided in the package archive (`hs-style`). @@ -147,7 +190,7 @@ txt <- readFile "BlogLiteratelyDoc.lhs" length txt -`BlogLiterately` will generate the following output:+`BlogLiterately` generates the following output: [ghci] :t hailstone@@ -156,11 +199,12 @@ 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.+(And yes, of course, the above output really *was* generated by+BlogLiterately!) Additionally, lines indented by one or more spaces+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@@ -199,9 +243,9 @@ 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- `()`).+ the usual `it` variable bound to the result of the previous+ expression is not available (well, to be more precise, it *is*+ available... but is always equal to `()`). Uploading embedded images -------------------------@@ -254,11 +298,11 @@ Command-line options -------------------- -The options for `BlogLiterately` are hopefully self-explanatory, given the-above background:+Most of the command-line options for `BlogLiterately` are hopefully+self-explanatory, given the above background: - BlogLierately v0.4, (c) Robert Greayer 2008-2010, Brent Yorgey 2012- This program comes with ABSOLUTELY NO WARRANTY+ BlogLierately v0.6, (c) Robert Greayer 2008-2010, Brent Yorgey 2012-2013+ For help, see http://byorgey.wordpress.com/blogliterately/ BlogLiterately [OPTIONS] FILE @@ -268,54 +312,123 @@ --hscolour-css highlight haskell: hscolour, separate stylesheet --hs-nohighlight no haskell highlighting --hs-kate highlight haskell with highlighting-kate- --other-kate highlight other code with highlighting-kate+ --kate highlight non-Haskell code with highlighting-kate+ (default)+ --no-kate don't highlight non-Haskell code -w --wplatex reformat inline LaTeX the way WordPress expects+ -m --math=ITEM how to layout math, where+ --math=<pandoc-option>[=URL] -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)+ -I --upload-images upload local images+ -C --category=ITEM post category (can specify more than one)+ -T --tag=ITEM tag (can specify more than one) --blogid=ID Blog specific identifier- --blog=URL blog XML-RPC url (if omitted, html goes to stdout)+ -P --profile=STRING profile to use+ -b --blog=URL blog XML-RPC url (if omitted, html goes to stdout) -u --user=USER user name- --password=PASSWORD password+ -p --password=PASSWORD password -t --title=TITLE post title- --postid=ID Post to replace (if any)+ -i --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)+ -h --html-only don't upload anything; output HTML to stdout+ -x --xtra=ITEM extension arguments, for use with custom extensions -? --help Display help message -V --version Print version information -Example usage+Profiles+--------++Certain options, such as `--blog`, `--user`, and `--wplatex`, may be+the same for all your posts. You can create one or more *profiles*+specifying a set of options, which can then be specified simply by+referencing the profile, using the command-line option+`--profile`/`-P`. For example, to use the profile named `foo` you+would invoke++ BlogLiterately -P foo ...++(Alternately, you can also specify `profile = foo` within a `[BLOpts]`+block in the source file itself; see the next section.)++The profile *foo* should be stored in a file named `foo.cfg`, and+placed in the application directory for `BlogLiterately`: on POSIX+systems, this means `$HOME/.BlogLiterately/foo.cfg`; on Windows, it+typically means something like `C:/Documents And+Settings/user/Application Data/BlogLiterately/foo.cfg`.++The profile should consist of a number of options, listed one per+line, in the form++ optionname = value++Boolean options are specified by `true`, `on`, `false`, or `off`.+String values use normal Haskell syntax for strings, surrounded by+double quotes. Optionally, the double quotes may be omitted for+strings which do not contain spaces, double quotes, commas, or square+brackets. Lists use also use Haskell list syntax, with comma-separated+items surrounded by square brackets, except that the square brackets+may be omitted. For example, `myblog.cfg` might look like this:++ blog = http://some.url/xmlrpc.php+ user = joebloggs+ password = f7430nvj!$4+ wplatex = true+ ghci = on+ categories = foo, bar, "some really long category"++The list of options which are currently supported are: `style`,+`wplatex`, `math`, `ghci`, `upload-images`, `categories`, `tags`,+`blogid`, `profile`, `blog`, `user`, `password`, `title`, `postid`,+`page`, `publish`, `xtras`.++Option blocks ------------- -If you do not specify a blog URL, by default `BlogLiterately` simply-prints the generated HTML to stdout. So, to preview the generated-HTML before uploading requires merely something like+In addition, options may be specified inline, using a code block+marked with the `[BLOpts]`. For example, - BlogLiterately Sample.lhs+ [other]+ [BLOpts]+ profile = foo+ title = "My awesome blog post!"+ postid = 2000+ tags = [awesome, stuff, blogging]+ categories = [Writing, Stuff] -To actually post to, say, a WordPress blog, a basic command line would-be something like+ This is my awesome blog post. Here is some math: $\pi$, which will+ get formatted for WordPress because I chose the `foo` profile+ above, which includes `wplatex = true`. - BlogLiterately --blog http://blogurl.example.com/xmlrpc.php \- --user myname --password mypasswd --title "Sample" Sample.lhs+Such inline options use the same syntax as profiles, as described in+the previous section. -(which creates a new post). You can also omit the `--password` field,-in which case `BlogLiterately` will prompt you for your password.+Pandoc titles+------------- -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+Pandoc supports a special syntax for specifying the title, placing the+title on the first line marked with `%`. `BlogLiterately` supports+this format too, so the above example could also have been written as: - BlogLiterately --postid 37 --blog http://blogurl.example.com/xmlrpc.php \- --user myname --password mypasswd --title "Sample" Sample.lhs+ [other]+ % My awesome blog post! -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).+ [BLOpts]+ profile = foo+ postid = 2000+ ... +Generating HTML only+--------------------++In the past, to get a "preview" version of the HTML output written to+stdout, all you had to do was omit a `--blog` option. However, if you+specify a profile with a `blog` field, this is more problematic. For+this reason, a new option `--html-only` has been added. When this+option is specified, nothing is uploaded, and the HTML output is+written to stdout.+ Getting Help ------------ @@ -334,4 +447,4 @@ [Hackage]: http://hackage.haskell.org/ [MathML]: http://www.w3.org/Math/ [MathJax]: http://www.mathjax.org/-[bug tracker]: http://code.google.com/p/byorgey/issues/list?q=Project:BlogLiterately+[bug tracker]: http://github.com/byorgey/BlogLiterately/issues
src/Text/BlogLiterately/Block.hs view
@@ -13,9 +13,12 @@ module Text.BlogLiterately.Block ( unTag+ , onTag ) where -import Text.ParserCombinators.Parsec+import Data.Char (toLower)+import Text.Pandoc (Attr, Block (CodeBlock))+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@@ -30,3 +33,18 @@ txt <- many $ anyToken eof return (Just tg, txt)++-- | Run the given function on the attributes and source code of code+-- blocks with a tag matching the given tag (case insensitive). On+-- any other blocks (which don't have a matching tag, or are not code+-- blocks), run the other function.+onTag :: String -> (Attr -> String -> a) -> (Block -> a) -> Block -> a+onTag t f def b@(CodeBlock attr@(_, as, _) s)+ | lowercase t `elem` map lowercase (maybe id (:) tag $ as)+ = f attr src+ | otherwise = def b+ where (tag, src) = unTag s+onTag _ _ def b = def b++lowercase :: String -> String+lowercase = map toLower
src/Text/BlogLiterately/Ghci.hs view
@@ -35,20 +35,22 @@ ) 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 Control.Arrow (first)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)+import Data.Char (isSpace)+import Data.Functor ((<$>))+import Data.List (intercalate, isPrefixOf)+import System.IO+import System.Process (ProcessHandle,+ runInteractiveCommand,+ waitForProcess) -import Data.List.Split-import Text.Pandoc ( Pandoc, Block(CodeBlock), bottomUpM )+import Data.List.Split+import Text.Pandoc (Block (CodeBlock), Pandoc,+ bottomUpM) -import Text.BlogLiterately.Block ( unTag )+import Text.BlogLiterately.Block (onTag) -- | Information about a running process: stdin, stdout, stderr, and a -- handle.@@ -172,17 +174,12 @@ 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' = onTag "ghci" formatGhciBlock return - formatInlineGhci' b = return b+ formatGhciBlock attr src = do+ let inputs = parseGhciInputs src+ results <- zipWith GhciLine inputs <$> mapM ghciEval inputs+ return $ CodeBlock attr (intercalate "\n" $ map formatGhciResult results) parseGhciInputs :: String -> [GhciInput] parseGhciInputs = map mkGhciInput
src/Text/BlogLiterately/Highlight.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- |@@ -13,6 +14,7 @@ module Text.BlogLiterately.Highlight ( HsHighlight(..)+ , _HsColourInline , colourIt , litify , StylePrefs@@ -24,22 +26,32 @@ , colourisePandoc ) where -import Control.Monad ( liftM )-import Data.Maybe ( isNothing )-import qualified System.IO.UTF8 as U ( readFile )+import Control.Lens (makePrisms)+import Control.Monad (liftM)+import Data.Char (toLower)+import Data.List (find)+import Data.Maybe (fromMaybe, 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 Language.Haskell.HsColour (Output (..), hscolour)+import Language.Haskell.HsColour.Colourise (defaultColourPrefs)+import System.Console.CmdArgs (Data, Typeable)+import Text.Blaze.Html.Renderer.String (renderHtml)+import Text.Highlighting.Kate+import Text.Highlighting.Kate.Format.HTML (formatHtmlBlock)+import Text.Pandoc (Block (CodeBlock, RawBlock),+ Pandoc (..))+import Text.Pandoc.Definition+import Text.Pandoc.Shared (safeRead)+import Text.XML.HaXml hiding (find)+import Text.XML.HaXml.Posn (noPos) -import Text.BlogLiterately.Block ( unTag )+import Text.BlogLiterately.Block (unTag) +-- | Style preferences are specified as a list of mappings from class+-- attributes to CSS style attributes.+type StylePrefs = [(String,String)]+ -- | Four modes for highlighting Haskell. data HsHighlight = HsColourInline StylePrefs -- ^ Use hscolour and inline the styles.@@ -49,6 +61,8 @@ | HsNoHighlight -- ^ Do not highlight Haskell. deriving (Data,Typeable,Show,Eq) +makePrisms ''HsHighlight+ {- The literate Haskell that Pandoc finds in a file ends up in various@@ -156,10 +170,6 @@ 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@@ -184,9 +194,9 @@ -- | 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)+getStylePrefs :: Maybe FilePath -> IO StylePrefs+getStylePrefs Nothing = return defaultStylePrefs+getStylePrefs (Just 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@@ -278,3 +288,37 @@ colourisePandoc :: HsHighlight -> Bool -> Pandoc -> Pandoc colourisePandoc hsHighlight otherHighlight (Pandoc m blocks) = Pandoc m $ map (colouriseCodeBlock hsHighlight otherHighlight) blocks++--------------------------------------------------+-- highlight function+--------------------------------------------------++-- Copied here from+--+-- https://github.com/jgm/pandoc/blob/8b3a81e4dd8bf46a822980781e28d9777a076c6a/src/Text/Pandoc/Highlighting.hs#L63+--+-- Pandoc 1.11 hid the Text.Pandoc.Highlighting module so we can't+-- import it from there anymore (at least not for the moment).++lcLanguages :: [String]+lcLanguages = map (map toLower) languages++highlight :: (FormatOptions -> [SourceLine] -> a) -- ^ Formatter+ -> Attr -- ^ Attributes of the CodeBlock+ -> String -- ^ Raw contents of the CodeBlock+ -> Maybe a -- ^ Maybe the formatted result+highlight formatter (_, classes, keyvals) rawCode =+ let firstNum = case safeRead (fromMaybe "1" $ lookup "startFrom" keyvals) of+ Just n -> n+ Nothing -> 1+ fmtOpts = defaultFormatOpts{+ startNumber = firstNum,+ numberLines = any (`elem`+ ["number","numberLines", "number-lines"]) classes }+ lcclasses = map (map toLower) classes+ in case find (`elem` lcLanguages) lcclasses of+ Nothing -> Nothing+ Just language -> Just+ $ formatter fmtOpts{ codeClasses = [language],+ containerClasses = classes }+ $ highlightAs language rawCode
src/Text/BlogLiterately/Image.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- |@@ -19,30 +19,31 @@ , mkMediaObject ) where -import Control.Arrow ( first, second, (>>>), 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.Class ( lift )-import Control.Monad.Trans.Reader ( ReaderT, runReaderT, ask )-import Control.Monad.Trans.State ( StateT, runStateT, get, modify )-import qualified Data.ByteString.Char8 as B-import Data.Char ( toLower )-import Data.Functor ( (<$>) )-import Data.List ( isPrefixOf, intercalate )-import qualified Data.Map as M-import Data.Maybe ( fromMaybe )-import System.Directory ( doesFileExist )-import System.FilePath ( takeFileName, takeExtension )+import Control.Arrow (Kleisli (..), arr, first,+ runKleisli, second, (>>>))+import qualified Control.Category as C (Category, id)+import Control.Monad (liftM, unless)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)+import Control.Monad.Trans.State (StateT, get, modify, runStateT)+import qualified Data.ByteString.Char8 as B+import Data.Char (toLower)+import Data.Functor ((<$>))+import Data.List (intercalate, isPrefixOf)+import qualified Data.Map as M+import Data.Maybe (fromMaybe)+import System.Directory (doesFileExist)+import System.FilePath (takeExtension, takeFileName) import System.IO-import qualified System.IO.UTF8 as U ( readFile )-import System.Process ( ProcessHandle, waitForProcess- , runInteractiveCommand )+import qualified System.IO.UTF8 as U (readFile)+import System.Process (ProcessHandle,+ runInteractiveCommand,+ waitForProcess) +import Network.XmlRpc.Client (remote)+import Network.XmlRpc.Internals (Value (..), toValue) import Text.Pandoc-import Network.XmlRpc.Client ( remote )-import Network.XmlRpc.Internals ( Value(..), toValue ) import Text.BlogLiterately.Options @@ -56,8 +57,8 @@ -- @.BlogLiterately-uploaded-images@. uploadAllImages :: BlogLiterately -> Pandoc -> IO Pandoc uploadAllImages bl@(BlogLiterately{..}) p =- case blog of- Just xmlrpc -> do+ case (_blog, _htmlOnly) of+ (Just xmlrpc, h) | h /= Just True -> do uploaded <- readUploadedImages (p', uploaded') <- runStateT (bottomUpM (uploadOneImage xmlrpc) p) uploaded writeUploadedImages uploaded'@@ -120,7 +121,11 @@ putStrLn $ "\nFile not found: " ++ filePath return Nothing Just media -> do- val <- remote url "metaWeblog.newMediaObject" blogid user (fromMaybe "" password) media+ val <- remote url "metaWeblog.newMediaObject"+ (fromMaybe "default" _blogid)+ (fromMaybe "" _user)+ (fromMaybe "" _password)+ media putStrLn "done." return $ Just val
src/Text/BlogLiterately/Options.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- |@@ -12,106 +13,263 @@ ----------------------------------------------------------------------------- module Text.BlogLiterately.Options- ( BlogLiterately(..)- , blOpts+ (+ -- * BlogLiterately options record+ BlogLiterately(..), blOpts++ -- ** Lenses+ -- $lenses++ , style+ , hsHighlight+ , otherHighlight+ , wplatex+ , math+ , ghci+ , uploadImages+ , categories+ , tags+ , blogid+ , profile+ , blog+ , user+ , password+ , title+ , file+ , postid+ , page+ , publish+ , htmlOnly+ , xtra++ -- ** Default accessors+ -- $defaccess++ , style'+ , hsHighlight'+ , otherHighlight'+ , wplatex'+ , math'+ , ghci'+ , uploadImages'+ , blogid'+ , profile'+ , blog'+ , user'+ , password'+ , title'+ , file'+ , postid'+ , page'+ , publish'+ , htmlOnly' ) where -import Paths_BlogLiterately (version)-import Data.Version+import Control.Lens (makeLenses, view)+import Control.Monad (mplus)+import Data.Maybe (fromMaybe)+import Data.Monoid+import Data.Version+import Paths_BlogLiterately (version) -import System.Console.CmdArgs+import System.Console.CmdArgs -import Text.BlogLiterately.Highlight+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?- , math :: String -- ^ Indicate how to format Math- , 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+ { _style :: Maybe String -- ^ Name of a style file+ , _hsHighlight :: Maybe HsHighlight -- ^ Haskell highlighting mode+ , _otherHighlight :: Maybe Bool -- ^ Use highlighting-kate for+ -- non-Haskell?+ , _wplatex :: Maybe Bool -- ^ Format LaTeX for WordPress?+ , _math :: Maybe String -- ^ Indicate how to format math+ , _ghci :: Maybe Bool -- ^ Automatically process ghci sessions?+ , _uploadImages :: Maybe Bool -- ^ Automatically upload images?+ , _categories :: [String] -- ^ Categories for the post+ , _tags :: [String] -- ^ Tags for the post+ , _blogid :: Maybe String -- ^ Blog-specific identifier+ -- (e.g. for blogging software+ -- handling multiple blogs)+ , _profile :: Maybe String -- ^ Name of profile to use.+ , _blog :: Maybe String -- ^ Blog xmlrpc URL+ , _user :: Maybe String -- ^ Blog user name+ , _password :: Maybe String -- ^ Blog password (omit to be interactively prompted)+ , _title :: Maybe String -- ^ Post title+ , _file :: Maybe String -- ^ File to post+ , _postid :: Maybe String -- ^ ID of a post to update+ , _page :: Maybe Bool -- ^ Create a \"page\" instead of a post+ , _publish :: Maybe Bool -- ^ Should the post be published?+ -- (Otherwise it is uploaded as a draft.)+ , _htmlOnly :: Maybe Bool -- ^ Don't upload anything;+ -- just output HTML to+ -- stdout.+ , _xtra :: [String] -- ^ Extension arguments, for use e.g. by+ -- custom transforms } deriving (Show,Data,Typeable) +-- $lenses+-- We derive lenses for all the @BlogLiterately@ fields using the+-- @lens@ library.++makeLenses ''BlogLiterately++instance Monoid BlogLiterately where+ mempty =+ BlogLiterately+ { _style = Nothing+ , _hsHighlight = Nothing+ , _otherHighlight = Nothing+ , _wplatex = Nothing+ , _math = Nothing+ , _ghci = Nothing+ , _uploadImages = Nothing+ , _categories = []+ , _tags = []+ , _blogid = Nothing+ , _profile = Nothing+ , _blog = Nothing+ , _user = Nothing+ , _password = Nothing+ , _title = Nothing+ , _file = Nothing+ , _postid = Nothing+ , _page = Nothing+ , _publish = Nothing+ , _htmlOnly = Nothing+ , _xtra = []+ }++ mappend bl1 bl2 =+ BlogLiterately+ { _style = combine _style+ , _hsHighlight = combine _hsHighlight+ , _otherHighlight = combine _otherHighlight+ , _wplatex = combine _wplatex+ , _math = combine _math+ , _ghci = combine _ghci+ , _uploadImages = combine _uploadImages+ , _categories = combine _categories+ , _tags = combine _tags+ , _blogid = combine _blogid+ , _profile = combine _profile+ , _blog = combine _blog+ , _user = combine _user+ , _password = combine _password+ , _title = combine _title+ , _file = combine _file+ , _postid = combine _postid+ , _page = combine _page+ , _publish = combine _publish+ , _htmlOnly = combine _htmlOnly+ , _xtra = combine _xtra+ }+ where combine f = f bl1 `mplus` f bl2++--------------------------------------------------+-- Default accessors+--------------------------------------------------++-- $defaccess+-- Some convenient accessors that strip off the Maybe and return an+-- appropriate default value.++style' = fromMaybe "" . view style+hsHighlight' = fromMaybe (HsColourInline defaultStylePrefs) . view hsHighlight+otherHighlight' = fromMaybe True . view otherHighlight+wplatex' = fromMaybe False . view wplatex+math' = fromMaybe "" . view math+ghci' = fromMaybe False . view ghci+uploadImages' = fromMaybe False . view uploadImages+blogid' = fromMaybe "default" . view blogid+profile' = fromMaybe "" . view profile+blog' = fromMaybe "" . view blog+user' = fromMaybe "" . view user+password' = fromMaybe "" . view password+title' = fromMaybe "" . view title+file' = fromMaybe "" . view file+postid' = fromMaybe "" . view postid+page' = fromMaybe False . view page+publish' = fromMaybe False . view publish+htmlOnly' = fromMaybe False . view htmlOnly+ -- | Command-line configuration for use with @cmdargs@. blOpts :: BlogLiterately blOpts = BlogLiterately- { style = "" &= help "style specification (for --hscolour-icss)"- &= typFile- , hsHighlight = enum- [ (HsColourInline defaultStylePrefs)+ { _style = def &= help "style specification (for --hscolour-icss)"+ &= typFile+ &= name "style" &= name "s" &= explicit+ , _hsHighlight = enum+ [ Just (HsColourInline defaultStylePrefs) &= explicit &= name "hscolour-icss" &= help "highlight haskell: hscolour, inline style (default)"- , HsColourCSS+ , Just HsColourCSS &= explicit &= name "hscolour-css" &= help "highlight haskell: hscolour, separate stylesheet"- , HsNoHighlight+ , Just HsNoHighlight &= explicit &= name "hs-nohighlight" &= help "no haskell highlighting"- , HsKate+ , Just HsKate &= explicit &= name "hs-kate" &= help "highlight haskell with highlighting-kate" ]- , otherHighlight = enum- [ True+ , _otherHighlight = enum+ [ Just True &= explicit &= name "kate" &= help "highlight non-Haskell code with highlighting-kate (default)"- , False+ , Just False &= explicit &= name "no-kate" &= help "don't highlight non-Haskell code" ]- , wplatex = def &= help "reformat inline LaTeX the way WordPress expects"- , math = def &= help "how to layout math, where --math=<pandoc-option>[=URL]"- , 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+ , _wplatex = def &= help "reformat inline LaTeX the way WordPress expects"+ &= name "wplatex" &= name "w" &= explicit+ , _math = def &= help "how to layout math, where --math=<pandoc-option>[=URL]"+ &= name "math" &= name "m" &= explicit+ , _ghci = def &= help "run [ghci] blocks through ghci and include output"+ &= name "ghci" &= name "g" &= explicit+ , _uploadImages = def &= name "upload-images" &= name "I" &= explicit &= help "upload local images"+ , _page = def &= help "create a \"page\" instead of a post (WordPress only)"+ &= name "page" &= explicit+ , _publish = def &= help "publish post (otherwise it's uploaded as a draft)"+ &= name "publish" &= explicit+ , _htmlOnly = def &= help "don't upload anything; output HTML to stdout"+ &= name "html-only" &= name "h" &= explicit+ , _categories = def &= explicit- &= name "category"+ &= name "category" &= name "C" &= help "post category (can specify more than one)"- , tags = def+ , _tags = def &= explicit- &= name "tag"+ &= name "tag" &= name "T" &= 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"+ , _xtra = def+ &= help "extension arguments, for use with custom extensions"+ &= name "xtra" &= name "x" &= explicit+ , _blogid = def &= help "Blog specific identifier" &= typ "ID"+ &= name "blogid" &= explicit+ , _postid = def &= help "Post to replace (if any)" &= typ "ID"+ &= name "postid" &= name "i" &= explicit+ , _profile = def &= typ "STRING" &= help "profile to use"+ &= name "profile" &= name "P" &= explicit+ , _blog = def &= typ "URL" &= help "blog XML-RPC url (if omitted, HTML goes to stdout)"+ &= name "blog" &= name "b" &= explicit+ , _user = def &= typ "USER" &= help "user name"+ &= name "user" &= name "u" &= explicit+ , _password = def &= typ "PASSWORD" &= help "password"+ &= name "password" &= name "p" &= explicit+ , _title = def &= typ "TITLE" &= help "post title"+ &= name "title" &= name "t" &= explicit+ , _file = def &= argPos 0 &= typ "FILE" } &= program "BlogLiterately"- &= summary ("BlogLierately v" ++ showVersion version ++ ", (c) Robert Greayer 2008-2010, Brent Yorgey 2012\n" ++- "This program comes with ABSOLUTELY NO WARRANTY\n")+ &= summary ("BlogLierately v" ++ showVersion version ++ ", (c) Robert Greayer 2008-2010, Brent Yorgey 2012-2013\n" +++ "For help, see http://byorgey.wordpress.com/blogliterately/")
+ src/Text/BlogLiterately/Options/Parse.hs view
@@ -0,0 +1,89 @@+-----------------------------------------------------------------------------+-- |+-- Module : Text.BlogLiterately.Options.Parse+-- Copyright : (c) 2013 Brent Yorgey+-- License : GPL (see LICENSE)+-- Maintainer : Brent Yorgey <byorgey@gmail.com>+--+-- Parsing configuration options from special @[BLOpts]@ blocks.+--+-----------------------------------------------------------------------------++module Text.BlogLiterately.Options.Parse+ ( readBLOptions+ , readBLOption+ , parseBLOption+ ) where++import Control.Applicative (pure, (*>), (<$>), (<*))+import Control.Arrow (second)+import Control.Lens ((&), (.~))+import Data.Char (isSpace)+import Data.Either (partitionEithers)+import Data.Monoid (mconcat, mempty)+import Text.Parsec (ParseError, char, many, noneOf,+ optional, parse, sepBy, spaces,+ string, try, (<|>))+import Text.Parsec.Language (haskell)+import Text.Parsec.String (Parser)+import Text.Parsec.Token (stringLiteral)+++import Text.BlogLiterately.Options++--------------------------------------------------+-- Parsing options+--------------------------------------------------++-- | Convert the contents of a @[BLOpts]@ block into an options record+-- and a list of parse errors.+readBLOptions :: String -> ([ParseError], BlogLiterately)+readBLOptions = second mconcat+ . partitionEithers+ . map readBLOption+ . filter (not . all isSpace)+ . lines++-- | Read a single line from a @[BLOpts]@ block.+readBLOption :: String -> Either ParseError BlogLiterately+readBLOption = parse parseBLOption ""++-- | Parse a single line from a @[BLOpts]@ block.+parseBLOption :: Parser BlogLiterately+parseBLOption =+ parseField style "style" parseStr+ <|> parseField wplatex "wplatex" parseBool+ <|> parseField math "math" parseStr+ <|> parseField ghci "ghci" parseBool+ <|> parseField uploadImages "upload-images" parseBool+ <|> parseField categories "categories" parseStrList+ <|> parseField tags "tags" parseStrList+ <|> parseField blogid "blogid" parseStr+ <|> parseField profile "profile" parseStr+ <|> parseField blog "blog" parseStr+ <|> parseField user "user" parseStr+ <|> parseField password "password" parseStr+ <|> parseField title "title" parseStr+ <|> parseField postid "postid" parseStr+ <|> parseField page "page" parseBool+ <|> parseField publish "publish" parseBool+ <|> parseField htmlOnly "html-only" parseBool+ <|> parseField xtra "xtras" parseStrList++str = stringLiteral haskell <|> many (noneOf " \t\n\r,\"[]")+parseStr = Just <$> str+parseBool = Just <$> ( ((string "true" <|> try (string "on")) *> pure True)+ <|> ((string "false" <|> string "off") *> pure False)+ )++parseStrList = optional (char '[') *> paddedStr `sepBy` (char ',') <* optional (char ']')+ where+ paddedStr = spaces *> str <* spaces++parseField fld name p = do+ try (string name)+ spaces+ char '='+ spaces+ value <- p+ return (mempty & fld .~ value)
src/Text/BlogLiterately/Post.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-} ----------------------------------------------------------------------------- -- |@@ -17,13 +17,14 @@ mkPost, mkArray, postIt ) where -import Control.Monad ( unless )-import Data.Maybe ( fromMaybe )+import Control.Lens ((^.))+import Control.Monad (unless)+import Data.Maybe (fromMaybe) -import Network.XmlRpc.Client ( remote )-import Network.XmlRpc.Internals ( Value(..), toValue, XmlRpcType )+import Network.XmlRpc.Client (remote)+import Network.XmlRpc.Internals (Value (..), XmlRpcType, toValue) -import Text.BlogLiterately.Options+import Text.BlogLiterately.Options {- The metaWeblog API defines `newPost` and `editPost` procedures that@@ -97,18 +98,30 @@ -- | 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+postIt bl html =+ case (bl^.blog, bl^.htmlOnly) of+ (Nothing , _ ) -> putStr html+ (_ , Just True ) -> putStr html+ (Just url , _ ) -> do+ let pwd = password' bl+ case bl^.postid of Nothing -> do- pid <- remote url "metaWeblog.newPost" blogid user pwd- (mkPost title html categories tags page) publish+ pid <- remote url "metaWeblog.newPost"+ (blogid' bl)+ (user' bl)+ pwd+ post+ (publish' bl) putStrLn $ "Post ID: " ++ pid Just pid -> do- success <- remote url "metaWeblog.editPost" pid user pwd- (mkPost title html categories tags page) publish+ success <- remote url "metaWeblog.editPost" pid+ (user' bl)+ pwd+ post+ (publish' bl) unless success $ putStrLn "update failed!"-+ where+ post = mkPost+ (title' bl)+ html (bl^.categories) (bl^.tags)+ (page' bl)
src/Text/BlogLiterately/Run.hs view
@@ -1,9 +1,9 @@-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Text.BlogLiterately.Run--- Copyright : (c) 2012 Brent Yorgey+-- Copyright : (c) 2012-2013 Brent Yorgey -- License : GPL (see LICENSE) -- Maintainer : Brent Yorgey <byorgey@gmail.com> --@@ -17,8 +17,9 @@ -- > module Main where -- > import Text.BlogLiterately -- >--- > myCustomXF = Transform ...--- > main = blogLiteratelyWith [myCustomXF, centerImagesXF]+-- > myCustomXF1 = pureTransform ...+-- > myCustomXF2 = Transform ...+-- > main = blogLiteratelyWith [myCustomXF1, myCustomXF2] -- -- See "Text.BlogLiterately.Transform" for examples of transforms, -- additional transforms which are not enabled by default, and help in@@ -34,14 +35,15 @@ ) where -import System.Console.CmdArgs ( cmdArgs)-import System.IO ( hFlush, stdout )-import qualified System.IO.UTF8 as U ( readFile )+import Control.Lens (set, use, (%=), (&), (.=), (.~),+ (^.))+import System.Console.CmdArgs (cmdArgs)+import qualified System.IO.UTF8 as U (readFile) -import Text.BlogLiterately.Highlight-import Text.BlogLiterately.Options-import Text.BlogLiterately.Post-import Text.BlogLiterately.Transform+import Text.BlogLiterately.Options (blOpts, file')+import Text.BlogLiterately.Post (postIt)+import Text.BlogLiterately.Transform (Transform, standardTransforms,+ xformDoc) -- | The default BlogLiterately application. blogLiterately :: IO ()@@ -50,33 +52,15 @@ -- | Like 'blogLiterately', but with the ability to specify additional -- 'Transform's which will be applied /after/ the standard ones. blogLiteratelyWith :: [Transform] -> IO ()-blogLiteratelyWith ts = blogLiteratelyCustom (standardTransforms ++ ts)+blogLiteratelyWith = blogLiteratelyCustom . (standardTransforms ++) -- | Like 'blogLiterately', but with the ability to /replace/ the -- standard 'Transform's. 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+blogLiteratelyCustom ts =+ cmdArgs blOpts+ >>= \bl -> U.readFile (file' bl)+ >>= xformDoc bl ts+ >>= uncurry postIt
src/Text/BlogLiterately/Transform.hs view
@@ -1,10 +1,12 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- -- | -- Module : Text.BlogLiterately.Transform--- Copyright : (c) 2008-2010 Robert Greayer, 2012 Brent Yorgey+-- Copyright : (c) 2008-2010 Robert Greayer, 2012-2013 Brent Yorgey -- License : GPL (see LICENSE) -- Maintainer : Brent Yorgey <byorgey@gmail.com> --@@ -14,48 +16,65 @@ ----------------------------------------------------------------------------- module Text.BlogLiterately.Transform- ( -- * Transforms- Transform(..), runTransform, runTransforms-+ ( -- * Standard transforms -- $standard + standardTransforms++ , optionsXF+ , profileXF+ , highlightOptsXF+ , passwordXF+ , titleXF , wptexifyXF , ghciXF- , imagesXF+ , uploadImagesXF , highlightXF- , standardTransforms-- -- * Other transforms- -- $other- , centerImagesXF + -- * Transforms+ , Transform(..), pureTransform, ioTransform, runTransform, runTransforms+ -- * Transforming documents , xformDoc -- * Utilities- , whenA, fixLineEndings+ , fixLineEndings ) where -import Control.Arrow ( first, (>>>), arr- , Kleisli(..), runKleisli )-import qualified Control.Category as C ( Category, id )-import qualified Data.Traversable as T-import Data.Default ( def )-import qualified Data.Set as S-import Data.Bool.Extras ( whenA )-import Data.List ( isPrefixOf )--import Text.Blaze.Html.Renderer.String ( renderHtml )+import Control.Applicative (pure, (<$>), (<**>))+import Control.Arrow ((>>>))+import Control.Lens (has, isn't, set, use, (%=),+ (&), (.=), (.~), (^.), _1,+ _2, _Just)+import Control.Monad.State+import Data.Default (def)+import Data.List (intercalate, isPrefixOf)+import Data.Monoid (mappend)+import Data.Monoid (mempty, (<>))+import qualified Data.Set as S+import qualified Data.Traversable as T+import System.Directory (doesFileExist,+ getAppUserDataDirectory)+import System.Exit (exitFailure)+import System.FilePath ((<.>), (</>))+import System.IO (hFlush, stdout)+import Text.Blaze.Html.Renderer.String (renderHtml) import Text.Pandoc import Text.Pandoc.Options+import Text.Parsec (ParseError) -import Text.BlogLiterately.Ghci-import Text.BlogLiterately.Highlight-import Text.BlogLiterately.Image-import Text.BlogLiterately.LaTeX+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) -- | A document transformation consists of two parts: an actual -- transformation, expressed as a function over Pandoc documents, and@@ -70,31 +89,53 @@ -- 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.+-- 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. 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.+ { 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) -> Transform+pureTransform transf cond = Transform (gets fst >>= \bl -> _2 %= transf bl) cond++-- | Construct a transformation from a function in the @IO@ monad.+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+ -- | 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+runTransform :: Transform -> StateT (BlogLiterately, Pandoc) IO ()+runTransform t = do+ bl <- gets fst+ when (xfCond t bl) $ getTransform t -- | Run a pipeline of 'Transform's.-runTransforms :: [Transform] -> BlogLiterately -> Kleisli IO Pandoc Pandoc-runTransforms ts = foldr (>>>) (C.id) . T.traverse runTransform ts+runTransforms :: [Transform] -> BlogLiterately -> Pandoc -> IO (BlogLiterately, Pandoc)+runTransforms ts bl p = execStateT (mapM_ runTransform ts) (bl,p) -------------------------------------------------- -- Standard transforms@@ -102,44 +143,31 @@ -- $standard -- These transforms are enabled by default in the standard--- BlogLiterately executable.+-- @BlogLiterately@ executable. -- | Format embedded LaTeX for WordPress (if the @wplatex@ flag is set). wptexifyXF :: Transform-wptexifyXF = Transform (const (arr wpTeXify)) wplatex+wptexifyXF = pureTransform (const wpTeXify) wplatex' -- | Format embedded @ghci@ sessions (if the @ghci@ flag is set). ghciXF :: Transform-ghciXF = Transform (Kleisli . formatInlineGhci . file) ghci+ghciXF = ioTransform (formatInlineGhci . file') ghci' -- | Upload embedded local images to the server (if the @uploadImages@ -- flag is set).-imagesXF :: Transform-imagesXF = Transform (Kleisli . uploadAllImages) uploadImages+uploadImagesXF :: Transform+uploadImagesXF = ioTransform uploadAllImages uploadImages' -- | Perform syntax highlighting on code blocks. highlightXF :: Transform-highlightXF = Transform- (\bl -> arr (colourisePandoc (hsHighlight bl) (otherHighlight bl)))+highlightXF = pureTransform+ (\bl -> 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]------------------------------------------------------- Other transforms------------------------------------------------------- $other--- These transforms are not enabled by default. To use them, see--- "Text.BlogLiterately.Run".- -- | Center any images which occur in a paragraph by themselves. -- Inline images are not affected. centerImagesXF :: Transform-centerImagesXF = Transform (const . arr $ centerImages) (const True)+centerImagesXF = pureTransform (const centerImages) (const True) centerImages :: Pandoc -> Pandoc centerImages = bottomUp centerImage@@ -152,17 +180,154 @@ : bs centerImage bs = bs +-- | Potentially extract a title from the metadata block, and set it+-- in the options record.+titleXF :: Transform+titleXF = Transform extractTitle (const True)+ where+ extractTitle = do+ (Pandoc (Meta t _ _) _) <- gets snd+ case t of+ [] -> return ()+ is ->+ -- title set explicitly with --title takes precedence.+ _1.title %= (`mplus` Just (intercalate " " [s | Str s <- is]))++-- | Extract blocks tagged with @[BLOpts]@ and use their contents as+-- options.+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'++-- | 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" (const readBLOptions) (const mempty)++-- | Delete any blocks tagged with @[BLOpts]@.+killOptionBlocks :: Block -> Block+killOptionBlocks = onTag "blopts" (const (const Null)) id++-- | Prompt the user for a password if the @blog@ field is set but no+-- password has been provided.+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++-- | Read a user-supplied style file and add its contents to the+-- highlighting options.+highlightOptsXF :: Transform+highlightOptsXF = Transform doHighlightOptsXF (const True)+ where+ doHighlightOptsXF = do+ prefs <- (liftIO . getStylePrefs) =<< use (_1 . style)+ (_1 . hsHighlight) %= Just . maybe (HsColourInline prefs)+ (_HsColourInline .~ prefs)++-- | Load options from a profile if one is specified.+profileXF :: Transform+profileXF = Transform doProfileXF (const True)+ where+ doProfileXF = do+ bl <- use _1+ bl' <- liftIO $ loadProfile bl+ _1 .= bl'++-- | Load additional options from a profile specified in the options+-- record.+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++-- | 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 String)-xformDoc bl xforms = runKleisli $- arr fixLineEndings- >>> arr (readMarkdown parseOpts)+xformDoc :: BlogLiterately -> [Transform] -> String -> IO (BlogLiterately, String)+xformDoc bl xforms =+ fixLineEndings+ >>> readMarkdown parseOpts >>> runTransforms xforms bl - >>> arr (writeHtml writeOpts)- >>> arr renderHtml+ >=> _2 (return . writeHtml writeOpts)+ >=> _2 (return . renderHtml) where parseOpts = def { readerExtensions = Ext_literate_haskell@@ -172,7 +337,7 @@ writeOpts = def { writerReferenceLinks = True , writerHTMLMathMethod =- case math bl of+ case math' bl of "" -> PlainMath opt -> mathOption opt } mathOption opt