BlogLiterately 0.6.3.1 → 0.7
raw patch · 13 files changed
+176/−67 lines, 13 filesdep +pandoc-citeproc
Dependencies added: pandoc-citeproc
Files
- BlogLiterately.cabal +2/−1
- CHANGES.md +5/−0
- doc/BlogLiteratelyDoc.lhs +46/−3
- main/BlogLiterately.hs +1/−0
- src/Text/BlogLiterately/Block.hs +1/−1
- src/Text/BlogLiterately/Ghci.hs +17/−12
- src/Text/BlogLiterately/Highlight.hs +11/−14
- src/Text/BlogLiterately/Image.hs +4/−13
- src/Text/BlogLiterately/Options.hs +56/−0
- src/Text/BlogLiterately/Options/Parse.hs +11/−4
- src/Text/BlogLiterately/Post.hs +7/−8
- src/Text/BlogLiterately/Run.hs +0/−2
- src/Text/BlogLiterately/Transform.hs +15/−9
BlogLiterately.cabal view
@@ -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
CHANGES.md view
@@ -1,3 +1,8 @@+0.7 (2 November 2013)+---------------------++ * Add support for citations.+ 0.6.3.1 (10 October 2013) -------------------------
doc/BlogLiteratelyDoc.lhs view
@@ -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
main/BlogLiterately.hs view
@@ -1,3 +1,4 @@ import Text.BlogLiterately.Run +main :: IO () main = blogLiterately
src/Text/BlogLiterately/Block.hs view
@@ -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)
src/Text/BlogLiterately/Ghci.hs view
@@ -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 = "<span style=\"color: " ++ color ++ ";\">" ++ txt ++ "</span>" 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...
src/Text/BlogLiterately/Highlight.hs view
@@ -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 = "<pre><code>" ++ s ++ "</code></pre>"- myHighlightK attr s = case highlight formatHtmlBlock attr s of+ simpleHTML h = "<pre><code>" ++ h ++ "</code></pre>"+ myHighlightK attrs h = case highlight formatHtmlBlock attrs h of Nothing -> rawHtml $ simpleHTML s Just html -> rawHtml $ replaceBreaks $ renderHtml html rawHtml = RawBlock (Format "html")
src/Text/BlogLiterately/Image.hs view
@@ -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"
src/Text/BlogLiterately/Options.hs view
@@ -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"
src/Text/BlogLiterately/Options/Parse.hs view
@@ -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)
src/Text/BlogLiterately/Post.hs view
@@ -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.
src/Text/BlogLiterately/Run.hs view
@@ -35,8 +35,6 @@ ) where -import Control.Lens (set, use, (%=), (&), (.=), (.~),- (^.)) import System.Console.CmdArgs (cmdArgs) import qualified System.IO.UTF8 as U (readFile)
src/Text/BlogLiterately/Transform.hs view
@@ -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" "<div style=\"text-align: center;\">" : img : RawBlock "html" "</div>"@@ -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.