diff --git a/BlogLiterately.cabal b/BlogLiterately.cabal --- a/BlogLiterately.cabal +++ b/BlogLiterately.cabal @@ -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 Maintainer: Brent Yorgey 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 diff --git a/CHANGES b/CHANGES deleted file mode 100644 --- a/CHANGES +++ /dev/null @@ -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 diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 --- /dev/null +++ b/CHANGES.md @@ -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 diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -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). diff --git a/doc/BlogLiteratelyDoc.lhs b/doc/BlogLiteratelyDoc.lhs --- a/doc/BlogLiteratelyDoc.lhs +++ b/doc/BlogLiteratelyDoc.lhs @@ -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=[=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 diff --git a/src/Text/BlogLiterately/Block.hs b/src/Text/BlogLiterately/Block.hs --- a/src/Text/BlogLiterately/Block.hs +++ b/src/Text/BlogLiterately/Block.hs @@ -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 diff --git a/src/Text/BlogLiterately/Ghci.hs b/src/Text/BlogLiterately/Ghci.hs --- a/src/Text/BlogLiterately/Ghci.hs +++ b/src/Text/BlogLiterately/Ghci.hs @@ -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 diff --git a/src/Text/BlogLiterately/Highlight.hs b/src/Text/BlogLiterately/Highlight.hs --- a/src/Text/BlogLiterately/Highlight.hs +++ b/src/Text/BlogLiterately/Highlight.hs @@ -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 diff --git a/src/Text/BlogLiterately/Image.hs b/src/Text/BlogLiterately/Image.hs --- a/src/Text/BlogLiterately/Image.hs +++ b/src/Text/BlogLiterately/Image.hs @@ -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 diff --git a/src/Text/BlogLiterately/Options.hs b/src/Text/BlogLiterately/Options.hs --- a/src/Text/BlogLiterately/Options.hs +++ b/src/Text/BlogLiterately/Options.hs @@ -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=[=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=[=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/") diff --git a/src/Text/BlogLiterately/Options/Parse.hs b/src/Text/BlogLiterately/Options/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Text/BlogLiterately/Options/Parse.hs @@ -0,0 +1,89 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.BlogLiterately.Options.Parse +-- Copyright : (c) 2013 Brent Yorgey +-- License : GPL (see LICENSE) +-- Maintainer : Brent Yorgey +-- +-- 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) diff --git a/src/Text/BlogLiterately/Post.hs b/src/Text/BlogLiterately/Post.hs --- a/src/Text/BlogLiterately/Post.hs +++ b/src/Text/BlogLiterately/Post.hs @@ -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) diff --git a/src/Text/BlogLiterately/Run.hs b/src/Text/BlogLiterately/Run.hs --- a/src/Text/BlogLiterately/Run.hs +++ b/src/Text/BlogLiterately/Run.hs @@ -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 -- @@ -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 diff --git a/src/Text/BlogLiterately/Transform.hs b/src/Text/BlogLiterately/Transform.hs --- a/src/Text/BlogLiterately/Transform.hs +++ b/src/Text/BlogLiterately/Transform.hs @@ -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 -- @@ -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