diff --git a/BlogLiterately.cabal b/BlogLiterately.cabal --- a/BlogLiterately.cabal +++ b/BlogLiterately.cabal @@ -1,5 +1,5 @@ Name: BlogLiterately -Version: 0.6.3.1 +Version: 0.7 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 @@ -58,6 +58,7 @@ haxr >= 3000.9 && < 3000.11, pandoc >= 1.12 && < 1.13, pandoc-types >= 1.12 && < 1.13, + pandoc-citeproc >= 0.1.2 && < 0.2, highlighting-kate >= 0.5 && < 0.6, data-default >= 0.5 && < 0.6, lens >= 3.8 && < 3.10 diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,8 @@ +0.7 (2 November 2013) +--------------------- + + * Add support for citations. + 0.6.3.1 (10 October 2013) ------------------------- diff --git a/doc/BlogLiteratelyDoc.lhs b/doc/BlogLiteratelyDoc.lhs --- a/doc/BlogLiteratelyDoc.lhs +++ b/doc/BlogLiteratelyDoc.lhs @@ -155,6 +155,47 @@ Sample stylesheets are provided in the package archive file (`kate.css`, `hscolour.css`). +Citations +--------- + +`BlogLiterately` can take advantage of `pandoc`'s ability to process +and typeset citations. To include citations in your blog post: + +1. Specify a bibliography---either the name of a bibliography file, or + an explicit list of references---as metadata in your document. With + Markdown, this is accomplished with a YAML document enclosed by `---` + at the beginning of the file (see the Pandoc documentation on [YAML + metadata + blocks](http://johnmacfarlane.net/pandoc/demo/example9/pandocs-markdown.html#yaml-metadata-block)). + For example, + + --- + title: My Blog Post + bibliography: references.bib + --- + Foo bar [@doe2006]. + + (There is no support yet for citations if you are using + reStructuredText; yell if you want it.) You can specify the name of a + file containing a bibliography, as in the example above; here is [a + list of the bibliography formats that are + accepted](https://github.com/jgm/pandoc-citeproc/blob/master/README.md). + Alternately, you can [give an explicit list of references](http://johnmacfarlane.net/pandoc/README.html#citations). + +2. Include citations, formatted like `[@doe2006]` for a normal + citation like (Doe, 2006); `@doe2006` for a text citation like Doe + (2006), or `[-@doe2006]` for a citation without the name (for + situations when the name already occurred elsewhere in the sentence). + See the [pandoc documentation for more details and + examples](http://johnmacfarlane.net/pandoc/README.html#citations). + +3. Simply run `BlogLiterately`; citation processing is on by + default. (You can explicitly turn it on with the `--citations` flag; + to turn it off, use `--no-citations`.) Citations will be typeset and + a bibliography will be appended at the end. You may want to include a + section heading like `# References` or `# Bibliography` at the end of + your post, to go above the generated bibliography. + LaTeX ----- @@ -331,7 +372,7 @@ Most of the command-line options for `BlogLiterately` are hopefully self-explanatory, given the above background: - BlogLierately v0.6, (c) Robert Greayer 2008-2010, Brent Yorgey 2012-2013 + BlogLierately v0.7, (c) Robert Greayer 2008-2010, Brent Yorgey 2012-2013 For help, see http://byorgey.wordpress.com/blogliterately/ BlogLiterately [OPTIONS] FILE @@ -354,15 +395,17 @@ -T --tag=ITEM tag (can specify more than one) --blogid=ID Blog specific identifier -P --profile=STRING profile to use - -b --blog=URL blog XML-RPC url (if omitted, html goes to stdout) + -b --blog=URL blog XML-RPC url (if omitted, HTML goes to stdout) -u --user=USER user name -p --password=PASSWORD password -t --title=TITLE post title + -f --format=FORMAT input format: markdown or rst -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 - + --citations process citations (default) + --no-citations do not process citations -x --xtra=ITEM extension arguments, for use with custom extensions -? --help Display help message -V --version Print version information diff --git a/main/BlogLiterately.hs b/main/BlogLiterately.hs --- a/main/BlogLiterately.hs +++ b/main/BlogLiterately.hs @@ -1,3 +1,4 @@ import Text.BlogLiterately.Run +main :: IO () main = blogLiterately 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 @@ -29,7 +29,7 @@ tag = do tg <- between (char '[') (char ']') $ many $ noneOf "[]" skipMany $ oneOf " \t" - (string "\r\n" <|> string "\n") + _ <- (string "\r\n" <|> string "\n") txt <- many $ anyToken eof return (Just tg, txt) 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 @@ -58,7 +58,7 @@ -- | An input to ghci consists of an expression/command, possibly -- paired with an expected output. -data GhciInput = GhciInput { expr :: String, expected :: Maybe String } +data GhciInput = GhciInput String (Maybe String) deriving Show -- | An output from ghci is either a correct output, or an incorrect @@ -85,19 +85,19 @@ let out' = strip out case expected of Nothing -> return $ OK out' - Just exp - | out' == exp -> return $ OK out' - | otherwise -> return $ Unexpected out' exp + Just e + | out' == e -> return $ OK out' + | otherwise -> return $ Unexpected out' e -- | Start an external ghci process, run a computation with access to -- it, and finally stop the process. withGhciProcess :: FilePath -> ReaderT ProcessInfo IO a -> IO a withGhciProcess f m = do isLit <- isLiterate f - pi <- runInteractiveCommand $ "ghci -v0 -ignore-dot-ghci " + h <- runInteractiveCommand $ "ghci -v0 -ignore-dot-ghci " ++ (if isLit then f else "") - res <- runReaderT m pi - stopGhci pi + res <- runReaderT m h + stopGhci h return res -- | Poor man's check to see whether we have a literate Haskell file. @@ -149,7 +149,7 @@ -- we look for the next occurrence of prefix plus magic breaks :: ([a] -> Bool) -> [a] -> ([a], [a]) -breaks p [] = ([], []) +breaks _ [] = ([], []) breaks p as@(a : as') | p as = ([], as) | otherwise = first (a:) $ breaks p as' @@ -192,8 +192,9 @@ . lines mkGhciInput :: [String] -> GhciInput -mkGhciInput [i] = GhciInput i Nothing -mkGhciInput (i:exp) = GhciInput i (Just . unlines' . unindent $ exp) +mkGhciInput [] = GhciInput "" Nothing +mkGhciInput [i] = GhciInput i Nothing +mkGhciInput (i:expr) = GhciInput i (Just . unlines' . unindent $ expr) unlines' :: [String] -> String unlines' = intercalate "\n" @@ -203,25 +204,29 @@ where f = dropWhile isSpace . reverse unindent :: [String] -> [String] +unindent [] = [] unindent (x:xs) = map (drop indentAmt) (x:xs) where indentAmt = length . takeWhile (==' ') $ x indent :: Int -> String -> String indent n = unlines' . map (replicate n ' '++) . lines +colored, coloredBlock :: String -> String -> String colored color txt = "" ++ txt ++ "" coloredBlock color = unlines' . map (colored color) . lines +ghciPrompt :: String ghciPrompt = colored "gray" "ghci> " +formatGhciResult :: GhciLine -> String formatGhciResult (GhciLine (GhciInput input _) (OK output)) | all isSpace output = ghciPrompt ++ esc input | otherwise = ghciPrompt ++ esc input ++ "\n" ++ indent 2 (esc output) ++ "\n" -formatGhciResult (GhciLine (GhciInput input _) (Unexpected output exp)) +formatGhciResult (GhciLine (GhciInput input _) (Unexpected output expr)) = ghciPrompt ++ esc input ++ "\n" ++ indent 2 (coloredBlock "red" (esc output)) - ++ "\n" ++ indent 2 (coloredBlock "blue" (esc exp)) + ++ "\n" ++ indent 2 (coloredBlock "blue" (esc expr)) ++ "\n" -- XXX the styles above should be configurable... 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 @@ -30,7 +30,7 @@ import Control.Monad (liftM) import Data.Char (toLower) import Data.List (find) -import Data.Maybe (fromMaybe, isNothing) +import Data.Maybe (fromMaybe) import qualified System.IO.UTF8 as U (readFile) import Language.Haskell.HsColour (Output (..), hscolour) @@ -38,12 +38,9 @@ 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 hiding (find, attr, html) import Text.XML.HaXml.Posn (noPos) import Text.BlogLiterately.Block (unTag) @@ -216,7 +213,7 @@ where -- filter the document (an Hscoloured fragment of Haskell source) - filtDoc (Document p s e m) = c where + filtDoc (Document _ _ e _) = c where [c] = filts (CElem e noPos) -- the filter is a fold of individual filters for each CSS class @@ -240,7 +237,7 @@ where -- filter the document (a highlighting-kate highlighted fragment of -- haskell source) - filtDoc (Document p s e m) = c where + filtDoc (Document _ _ e _) = c where [c] = filts (CElem e noPos) filts = foldXml (literal "\n" `when` tag "br") @@ -258,20 +255,20 @@ -- markers), or marked up non-Haskell, if highlighting of non-Haskell has -- been selected. colouriseCodeBlock :: HsHighlight -> Bool -> Block -> Block -colouriseCodeBlock hsHighlight otherHighlight b@(CodeBlock attr@(_,classes,_) s) +colouriseCodeBlock hsHighlight otherHighlight (CodeBlock attr@(_,classes,_) s) - | tag == Just "haskell" || haskell + | ctag == Just "haskell" || haskell = case hsHighlight of HsColourInline style -> rawHtml $ bakeStyles style $ colourIt lit src HsColourCSS -> rawHtml $ colourIt lit src HsNoHighlight -> rawHtml $ simpleHTML hsrc - HsKate -> case tag of + HsKate -> case ctag of Nothing -> myHighlightK attr hsrc Just t -> myHighlightK ("", t:classes,[]) hsrc | otherHighlight - = case tag of + = case ctag of Nothing -> myHighlightK attr src Just t -> myHighlightK ("",[t],[]) src @@ -279,7 +276,7 @@ = rawHtml $ simpleHTML src where - (tag,src) + (ctag,src) | null classes = unTag s | otherwise = (Nothing, s) hsrc @@ -287,8 +284,8 @@ | otherwise = src lit = "sourceCode" `elem` classes haskell = "haskell" `elem` classes - simpleHTML s = "
" ++ s ++ "
" - myHighlightK attr s = case highlight formatHtmlBlock attr s of + simpleHTML h = "
" ++ h ++ "
" + myHighlightK attrs h = case highlight formatHtmlBlock attrs h of Nothing -> rawHtml $ simpleHTML s Just html -> rawHtml $ replaceBreaks $ renderHtml html rawHtml = RawBlock (Format "html") 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 @@ -19,27 +19,16 @@ , mkMediaObject ) where -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 Data.List (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, - runInteractiveCommand, - waitForProcess) import Network.XmlRpc.Client (remote) import Network.XmlRpc.Internals (Value (..), toValue) @@ -84,8 +73,9 @@ uploadOneImage _ i = return i isLocal imgUrl = none (`isPrefixOf` imgUrl) ["http", "/"] - none p = all (not . p) + none pr = all (not . pr) +uploadedImagesFile :: String uploadedImagesFile = ".BlogLiterately-uploaded-images" -- | Read the list of previously uploaded images and their associated URLs from @@ -149,3 +139,4 @@ "jpg" -> "image/jpeg" "jpeg" -> "image/jpeg" "gif" -> "image/gif" + _ -> "image/png" 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 @@ -41,6 +41,7 @@ , page , publish , htmlOnly + , citations , xtra -- ** Default accessors @@ -65,6 +66,7 @@ , page' , publish' , htmlOnly' + , citations' ) where @@ -110,6 +112,7 @@ , _htmlOnly :: Maybe Bool -- ^ Don't upload anything; -- just output HTML to -- stdout. + , _citations :: Maybe Bool -- ^ Process citations? (default: true) , _xtra :: [String] -- ^ Extension arguments, for use e.g. by -- custom transforms } @@ -145,6 +148,7 @@ , _page = Nothing , _publish = Nothing , _htmlOnly = Nothing + , _citations = Nothing , _xtra = [] } @@ -171,6 +175,7 @@ , _page = combine _page , _publish = combine _publish , _htmlOnly = combine _htmlOnly + , _citations = combine _citations , _xtra = combine _xtra } where combine f = f bl1 `mplus` f bl2 @@ -183,26 +188,66 @@ -- Some convenient accessors that strip off the Maybe and return an -- appropriate default value. +style' :: BlogLiterately -> String style' = fromMaybe "" . view style + +hsHighlight' :: BlogLiterately -> HsHighlight hsHighlight' = fromMaybe (HsColourInline defaultStylePrefs) . view hsHighlight + +otherHighlight' :: BlogLiterately -> Bool otherHighlight' = fromMaybe True . view otherHighlight + +wplatex' :: BlogLiterately -> Bool wplatex' = fromMaybe False . view wplatex + +math' :: BlogLiterately -> String math' = fromMaybe "" . view math + +ghci' :: BlogLiterately -> Bool ghci' = fromMaybe False . view ghci + +uploadImages' :: BlogLiterately -> Bool uploadImages' = fromMaybe False . view uploadImages + +blogid' :: BlogLiterately -> String blogid' = fromMaybe "default" . view blogid + +profile' :: BlogLiterately -> String profile' = fromMaybe "" . view profile + +blog' :: BlogLiterately -> String blog' = fromMaybe "" . view blog + +user' :: BlogLiterately -> String user' = fromMaybe "" . view user + +password' :: BlogLiterately -> String password' = fromMaybe "" . view password + +title' :: BlogLiterately -> String title' = fromMaybe "" . view title + +file' :: BlogLiterately -> String file' = fromMaybe "" . view file + +format' :: BlogLiterately -> String format' = fromMaybe "" . view format + +postid' :: BlogLiterately -> String postid' = fromMaybe "" . view postid + +page' :: BlogLiterately -> Bool page' = fromMaybe False . view page + +publish' :: BlogLiterately -> Bool publish' = fromMaybe False . view publish + +htmlOnly' :: BlogLiterately -> Bool htmlOnly' = fromMaybe False . view htmlOnly +citations' :: BlogLiterately -> Bool +citations' = fromMaybe True . view citations + -- | Command-line configuration for use with @cmdargs@. blOpts :: BlogLiterately blOpts = BlogLiterately @@ -258,6 +303,17 @@ &= explicit &= name "tag" &= name "T" &= help "tag (can specify more than one)" + + , _citations = enum + [ Just True + &= help "process citations (default)" + &= name "citations" + &= explicit + , Just False + &= help "do not process citations" + &= name "no-citations" + &= explicit + ] , _xtra = def &= help "extension arguments, for use with custom extensions" diff --git a/src/Text/BlogLiterately/Options/Parse.hs b/src/Text/BlogLiterately/Options/Parse.hs --- a/src/Text/BlogLiterately/Options/Parse.hs +++ b/src/Text/BlogLiterately/Options/Parse.hs @@ -17,10 +17,10 @@ import Control.Applicative (pure, (*>), (<$>), (<*)) import Control.Arrow (second) -import Control.Lens ((&), (.~)) +import Control.Lens ((&), (.~), ASetter') import Data.Char (isSpace) import Data.Either (partitionEithers) -import Data.Monoid (mconcat, mempty) +import Data.Monoid (mconcat, mempty, Monoid) import Text.Parsec (ParseError, char, many, noneOf, optional, parse, sepBy, spaces, string, try, (<|>)) @@ -70,20 +70,27 @@ <|> parseField htmlOnly "html-only" parseBool <|> parseField xtra "xtras" parseStrList +str :: Parser String str = stringLiteral haskell <|> many (noneOf " \t\n\r,\"[]") + +parseStr :: Parser (Maybe String) parseStr = Just <$> str + +parseBool :: Parser (Maybe Bool) parseBool = Just <$> ( ((string "true" <|> try (string "on")) *> pure True) <|> ((string "false" <|> string "off") *> pure False) ) +parseStrList :: Parser [String] parseStrList = optional (char '[') *> paddedStr `sepBy` (char ',') <* optional (char ']') where paddedStr = spaces *> str <* spaces +parseField :: ASetter' BlogLiterately a -> String -> Parser a -> Parser BlogLiterately parseField fld name p = do - try (string name) + _ <- try (string name) spaces - char '=' + _ <- 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 @@ -19,8 +19,7 @@ ) where import Control.Lens (at, makePrisms, to, traverse, - (^.), (^?), _Just) -import Control.Monad (unless) + (^.), (^?)) import qualified Data.Map as M import Network.XmlRpc.Client (remote) @@ -61,13 +60,13 @@ -> [String] -- ^ List of tags -> Bool -- ^ @True@ = page, @False@ = post -> [(String, Value)] -mkPost title text categories tags page = - mkArray "categories" categories - ++ mkArray "mt_keywords" tags - ++ [ ("title", toValue title) - , ("description", toValue text) +mkPost title_ text_ categories_ tags_ page_ = + mkArray "categories" categories_ + ++ mkArray "mt_keywords" tags_ + ++ [ ("title", toValue title_) + , ("description", toValue text_) ] - ++ [ ("post_type", toValue "page") | page ] + ++ [ ("post_type", toValue "page") | page_ ] -- | Given a name and a list of values, create a named \"array\" field -- suitable for inclusion in an XML-RPC struct. 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 @@ -35,8 +35,6 @@ ) where -import Control.Lens (set, use, (%=), (&), (.=), (.~), - (^.)) import System.Console.CmdArgs (cmdArgs) import qualified System.IO.UTF8 as U (readFile) 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 @@ -32,6 +32,7 @@ , uploadImagesXF , highlightXF , centerImagesXF + , citationsXF -- * Transforms , Transform(..), pureTransform, ioTransform, runTransform, runTransforms @@ -43,27 +44,25 @@ , fixLineEndings ) where -import Control.Applicative (pure, (<$>), (<**>)) +import Control.Applicative ((<$>)) import Control.Arrow ((>>>)) -import Control.Lens (has, isn't, set, use, (%=), +import Control.Lens (has, isn't, use, (%=), (&), (.=), (.~), (^.), _1, _2, _Just) import Control.Monad.State -import Data.Default (def) import Data.List (intercalate, isPrefixOf) import qualified Data.Map as M import Data.Monoid (mappend) import Data.Monoid (mempty, (<>)) import qualified Data.Set as S -import qualified Data.Traversable as T import System.Directory (doesFileExist, getAppUserDataDirectory) import System.Exit (exitFailure) import System.FilePath (takeExtension, (<.>), ()) import System.IO (hFlush, stdout) import Text.Blaze.Html.Renderer.String (renderHtml) +import Text.CSL.Pandoc (processCites') import Text.Pandoc -import Text.Pandoc.Options import Text.Parsec (ParseError) import Text.BlogLiterately.Block (onTag) @@ -174,7 +173,7 @@ centerImages = bottomUp centerImage where centerImage :: [Block] -> [Block] - centerImage (img@(Para [Image altText (imgUrl, imgTitle)]) : bs) = + centerImage (img@(Para [Image _altText (_imgUrl, _imgTitle)]) : bs) = RawBlock "html" "
" : img : RawBlock "html" "
" @@ -244,6 +243,10 @@ (_1 . hsHighlight) %= Just . maybe (HsColourInline prefs) (_HsColourInline .~ prefs) +-- | Format citations. +citationsXF :: Transform +citationsXF = ioTransform (const processCites') citations' + -- | Load options from a profile if one is specified. profileXF :: Transform profileXF = Transform doProfileXF (const True) @@ -296,6 +299,7 @@ -- -- * 'highlightXF': perform syntax highlighting -- +-- * 'citationsXF': process citations standardTransforms :: [Transform] standardTransforms = [ -- Has to go first, since it may affect later transforms. @@ -316,6 +320,7 @@ , centerImagesXF , highlightOptsXF , highlightXF + , citationsXF ] -------------------------------------------------- @@ -327,14 +332,14 @@ xformDoc :: BlogLiterately -> [Transform] -> String -> IO (BlogLiterately, String) xformDoc bl xforms = fixLineEndings - >>> parseFile bl parseOpts + >>> parseFile parseOpts >>> runTransforms xforms bl >=> _2 (return . writeHtml writeOpts) >=> _2 (return . renderHtml) where - parseFile bl opts = + parseFile opts = case bl^.format of Just "rst" -> readRST opts Just _ -> readMarkdown opts @@ -377,6 +382,7 @@ | opt `isPrefixOf` "jsmath" = JsMath (mathUrlMaybe opt) | opt `isPrefixOf` "mathjax" = MathJax (mathUrl mathJaxURL opt) | opt `isPrefixOf` "gladtex" = GladTeX + | otherwise = PlainMath webTeXURL = "http://chart.apis.google.com/chart?cht=tx&chl=" mathJaxURL = "http://cdn.mathjax.org/mathjax/latest/MathJax.js" @@ -385,7 +391,7 @@ urlPart = drop 1 . dropWhile (/='=') mathUrlMaybe opt = case urlPart opt of "" -> Nothing; x -> Just x - mathUrl def opt = case urlPart opt of "" -> def; x -> x + mathUrl dflt opt = case urlPart opt of "" -> dflt; x -> x -- | Turn @CRLF@ pairs into a single @LF@. This is necessary since -- 'readMarkdown' is picky about line endings.