{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections     #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Text.BlogLiterately.Transform
-- Copyright   :  (c) 2008-2010 Robert Greayer, 2012-2013 Brent Yorgey
-- License     :  GPL (see LICENSE)
-- Maintainer  :  Brent Yorgey <byorgey@gmail.com>
--
-- Tools for putting together a pipeline transforming the source for a
-- post into a completely formatted HTML document.
--
-----------------------------------------------------------------------------

module Text.BlogLiterately.Transform
    (
      -- * Standard transforms
      -- $standard

      standardTransforms

    , optionsXF
    , profileXF
    , highlightOptsXF
    , passwordXF
    , titleXF
    , rawtexifyXF
    , wptexifyXF
    , ghciXF
    , uploadImagesXF
    , highlightXF
    , centerImagesXF
    , citationsXF

      -- * Link generation
    , specialLinksXF
    , mkSpecialLinksXF
    , standardSpecialLinks
    , luckyLink
    , wikiLink
    , postLink

      -- * Transforms
    , Transform(..), pureTransform, ioTransform, pioTransform, runTransform, runTransforms

      -- * Transforming documents
    , xformDoc

      -- * Utilities
    , fixLineEndings
    ) where

import           Control.Applicative               ((<$>))
import           Control.Arrow                     ((>>>))
import           Control.Lens                      (has, isn't, use, (%=), (&),
                                                    (.=), (.~), (^.), _1, _2,
                                                    _Just)
import           Control.Monad.State
import           Data.Char                         (isDigit, toLower)
import           Data.List                         (intercalate, isInfixOf,
                                                    isPrefixOf)
import           Data.List.Split                   (splitOn)
import qualified Data.Map                          as M
import           Data.Maybe                        (fromMaybe)
import           Data.Monoid                       (mappend)
import           Data.Monoid                       (mempty, (<>))
import qualified Data.Set                          as S
import           Data.Text                         (Text)
import qualified Data.Text                         as T
import qualified Data.Text.Lazy                    as LT
import           Data.Traversable                  (traverse)
import           Network.HTTP                      (getRequest, getResponseBody,
                                                    simpleHTTP)
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.HTML.TagSoup
import           Text.Pandoc                       hiding (openURL)
import           Text.Pandoc.Citeproc              (processCitations)
import           Text.Pandoc.Error                 (PandocError)
import           Text.Parsec                       (ParseError)

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         (rawTeXify, wpTeXify)
import           Text.BlogLiterately.Options
import           Text.BlogLiterately.Options.Parse (readBLOptions)
import           Text.BlogLiterately.Post          (findTitle, getPostURL)

-- | A document transformation consists of two parts: an actual
--   transformation, expressed as a function over Pandoc documents, and
--   a condition specifying whether the transformation should actually
--   be applied.
--
--   The transformation itself takes a 'BlogLiterately' configuration
--   as an argument.  You may of course ignore it if you do not need
--   to know anything about the configuration.  The @--xtra@ (or @-x@)
--   flag is also provided especially as a method of getting
--   information from the command-line to custom extensions. Arguments
--   passed via @-x@ on the command line are available from the 'xtra'
--   field of the 'BlogLiterately' configuration.
--
--   The transformation is then specified as a 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
                 { Transform -> StateT (BlogLiterately, Pandoc) PandocIO ()
getTransform :: StateT (BlogLiterately, Pandoc) PandocIO ()
                   -- ^ 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.
                 , Transform -> BlogLiterately -> Bool
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 :: (BlogLiterately -> Pandoc -> Pandoc)
-> (BlogLiterately -> Bool) -> Transform
pureTransform BlogLiterately -> Pandoc -> Pandoc
transf = StateT (BlogLiterately, Pandoc) PandocIO ()
-> (BlogLiterately -> Bool) -> Transform
Transform (((BlogLiterately, Pandoc) -> BlogLiterately)
-> StateT (BlogLiterately, Pandoc) PandocIO BlogLiterately
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (BlogLiterately, Pandoc) -> BlogLiterately
forall a b. (a, b) -> a
fst StateT (BlogLiterately, Pandoc) PandocIO BlogLiterately
-> (BlogLiterately -> StateT (BlogLiterately, Pandoc) PandocIO ())
-> StateT (BlogLiterately, Pandoc) PandocIO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \BlogLiterately
bl -> (Pandoc -> Identity Pandoc)
-> (BlogLiterately, Pandoc) -> Identity (BlogLiterately, Pandoc)
forall s t a b. Field2 s t a b => Lens s t a b
_2 ((Pandoc -> Identity Pandoc)
 -> (BlogLiterately, Pandoc) -> Identity (BlogLiterately, Pandoc))
-> (Pandoc -> Pandoc)
-> StateT (BlogLiterately, Pandoc) PandocIO ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= BlogLiterately -> Pandoc -> Pandoc
transf BlogLiterately
bl)

-- | Construct a transformation from a function in the @IO@ monad.
ioTransform :: (BlogLiterately -> Pandoc -> IO Pandoc)
            -> (BlogLiterately -> Bool) -> Transform
ioTransform :: (BlogLiterately -> Pandoc -> IO Pandoc)
-> (BlogLiterately -> Bool) -> Transform
ioTransform BlogLiterately -> Pandoc -> IO Pandoc
transf = (BlogLiterately -> Pandoc -> PandocIO Pandoc)
-> (BlogLiterately -> Bool) -> Transform
pioTransform (\BlogLiterately
b Pandoc
p -> IO Pandoc -> PandocIO Pandoc
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (BlogLiterately -> Pandoc -> IO Pandoc
transf BlogLiterately
b Pandoc
p))

-- | Construct a transformation from a function in the @PandocIO@ monad.
pioTransform :: (BlogLiterately -> Pandoc -> PandocIO Pandoc)
             -> (BlogLiterately -> Bool) -> Transform
pioTransform :: (BlogLiterately -> Pandoc -> PandocIO Pandoc)
-> (BlogLiterately -> Bool) -> Transform
pioTransform BlogLiterately -> Pandoc -> PandocIO Pandoc
transf = StateT (BlogLiterately, Pandoc) PandocIO ()
-> (BlogLiterately -> Bool) -> Transform
Transform (StateT (BlogLiterately, Pandoc) PandocIO ()
 -> (BlogLiterately -> Bool) -> Transform)
-> StateT (BlogLiterately, Pandoc) PandocIO ()
-> (BlogLiterately -> Bool)
-> Transform
forall a b. (a -> b) -> a -> b
$ do
  (BlogLiterately
bl,Pandoc
p) <- StateT (BlogLiterately, Pandoc) PandocIO (BlogLiterately, Pandoc)
forall s (m :: * -> *). MonadState s m => m s
get
  Pandoc
p' <- PandocIO Pandoc -> StateT (BlogLiterately, Pandoc) PandocIO Pandoc
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PandocIO Pandoc
 -> StateT (BlogLiterately, Pandoc) PandocIO Pandoc)
-> PandocIO Pandoc
-> StateT (BlogLiterately, Pandoc) PandocIO Pandoc
forall a b. (a -> b) -> a -> b
$ BlogLiterately -> Pandoc -> PandocIO Pandoc
transf BlogLiterately
bl Pandoc
p
  (BlogLiterately, Pandoc)
-> StateT (BlogLiterately, Pandoc) PandocIO ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (BlogLiterately
bl,Pandoc
p')

-- | Run a 'Transform' (if its condition is met).
runTransform :: Transform -> StateT (BlogLiterately, Pandoc) PandocIO ()
runTransform :: Transform -> StateT (BlogLiterately, Pandoc) PandocIO ()
runTransform Transform
t = do
  BlogLiterately
bl <- ((BlogLiterately, Pandoc) -> BlogLiterately)
-> StateT (BlogLiterately, Pandoc) PandocIO BlogLiterately
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (BlogLiterately, Pandoc) -> BlogLiterately
forall a b. (a, b) -> a
fst
  Bool
-> StateT (BlogLiterately, Pandoc) PandocIO ()
-> StateT (BlogLiterately, Pandoc) PandocIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Transform -> BlogLiterately -> Bool
xfCond Transform
t BlogLiterately
bl) (StateT (BlogLiterately, Pandoc) PandocIO ()
 -> StateT (BlogLiterately, Pandoc) PandocIO ())
-> StateT (BlogLiterately, Pandoc) PandocIO ()
-> StateT (BlogLiterately, Pandoc) PandocIO ()
forall a b. (a -> b) -> a -> b
$ Transform -> StateT (BlogLiterately, Pandoc) PandocIO ()
getTransform Transform
t

-- | Run a pipeline of 'Transform's.
runTransforms :: [Transform] -> BlogLiterately -> Pandoc -> PandocIO (BlogLiterately, Pandoc)
runTransforms :: [Transform]
-> BlogLiterately -> Pandoc -> PandocIO (BlogLiterately, Pandoc)
runTransforms [Transform]
ts BlogLiterately
bl Pandoc
p = StateT (BlogLiterately, Pandoc) PandocIO ()
-> (BlogLiterately, Pandoc) -> PandocIO (BlogLiterately, Pandoc)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT ((Transform -> StateT (BlogLiterately, Pandoc) PandocIO ())
-> [Transform] -> StateT (BlogLiterately, Pandoc) PandocIO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Transform -> StateT (BlogLiterately, Pandoc) PandocIO ()
runTransform [Transform]
ts) (BlogLiterately
bl,Pandoc
p)

--------------------------------------------------
-- Standard transforms
--------------------------------------------------

-- $standard
-- These transforms are enabled by default in the standard
-- @BlogLiterately@ executable.

-- | Pass LaTeX (inline or display) through unchanged (if the @rawlatex@ flag is set).
rawtexifyXF :: Transform
rawtexifyXF :: Transform
rawtexifyXF = (BlogLiterately -> Pandoc -> Pandoc)
-> (BlogLiterately -> Bool) -> Transform
pureTransform ((Pandoc -> Pandoc) -> BlogLiterately -> Pandoc -> Pandoc
forall a b. a -> b -> a
const Pandoc -> Pandoc
rawTeXify) BlogLiterately -> Bool
rawlatex'

-- | Format embedded LaTeX for WordPress (if the @wplatex@ flag is set).
wptexifyXF :: Transform
wptexifyXF :: Transform
wptexifyXF = (BlogLiterately -> Pandoc -> Pandoc)
-> (BlogLiterately -> Bool) -> Transform
pureTransform ((Pandoc -> Pandoc) -> BlogLiterately -> Pandoc -> Pandoc
forall a b. a -> b -> a
const Pandoc -> Pandoc
wpTeXify) BlogLiterately -> Bool
wplatex'

-- | Format embedded @ghci@ sessions (if the @ghci@ flag is set).
ghciXF :: Transform
ghciXF :: Transform
ghciXF = (BlogLiterately -> Pandoc -> IO Pandoc)
-> (BlogLiterately -> Bool) -> Transform
ioTransform (FilePath -> Pandoc -> IO Pandoc
formatInlineGhci (FilePath -> Pandoc -> IO Pandoc)
-> (BlogLiterately -> FilePath)
-> BlogLiterately
-> Pandoc
-> IO Pandoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlogLiterately -> FilePath
file') BlogLiterately -> Bool
ghci'

-- | Upload embedded local images to the server (if the @uploadImages@
--   flag is set).
uploadImagesXF :: Transform
uploadImagesXF :: Transform
uploadImagesXF = (BlogLiterately -> Pandoc -> IO Pandoc)
-> (BlogLiterately -> Bool) -> Transform
ioTransform BlogLiterately -> Pandoc -> IO Pandoc
uploadAllImages BlogLiterately -> Bool
uploadImages'

-- | Perform syntax highlighting on code blocks.
highlightXF :: Transform
highlightXF :: Transform
highlightXF = (BlogLiterately -> Pandoc -> Pandoc)
-> (BlogLiterately -> Bool) -> Transform
pureTransform
  (\BlogLiterately
bl -> HsHighlight -> Bool -> Pandoc -> Pandoc
colourisePandoc (BlogLiterately -> HsHighlight
hsHighlight' BlogLiterately
bl) (BlogLiterately -> Bool
otherHighlight' BlogLiterately
bl))
  (Bool -> BlogLiterately -> Bool
forall a b. a -> b -> a
const Bool
True)

-- | Center any images which occur in a paragraph by themselves.
--   Inline images are not affected.
centerImagesXF :: Transform
centerImagesXF :: Transform
centerImagesXF = (BlogLiterately -> Pandoc -> Pandoc)
-> (BlogLiterately -> Bool) -> Transform
pureTransform ((Pandoc -> Pandoc) -> BlogLiterately -> Pandoc -> Pandoc
forall a b. a -> b -> a
const Pandoc -> Pandoc
centerImages) (Bool -> BlogLiterately -> Bool
forall a b. a -> b -> a
const Bool
True)

centerImages :: Pandoc -> Pandoc
centerImages :: Pandoc -> Pandoc
centerImages = ([Block] -> [Block]) -> Pandoc -> Pandoc
forall a b. (Data a, Data b) => (a -> a) -> b -> b
bottomUp [Block] -> [Block]
centerImage
  where
    centerImage :: [Block] -> [Block]
    centerImage :: [Block] -> [Block]
centerImage (img :: Block
img@(Para [Image Attr
_attr [Inline]
_altText (Text
_imgUrl, Text
_imgTitle)]) : [Block]
bs) =
        Format -> Text -> Block
RawBlock (Text -> Format
Format Text
"html") Text
"<div style=\"text-align: center;\">"
      Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: Block
img
      Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: Format -> Text -> Block
RawBlock (Text -> Format
Format Text
"html") Text
"</div>"
      Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: [Block]
bs
    centerImage [Block]
bs = [Block]
bs

-- | Replace special links with appropriate URLs.  Currently, the
--   following types of special links are supported:
--
--   [@lucky::<search>@] The first Google result for @<search>@.
--
--   [@wiki::<title>@] The Wikipedia page for @<title>@.  Note that
--   the page is not checked for existence.
--
--   [@hackage::<pkg>@] The Hackage page for @<pkg>@.
--
--   [@github::<user>/<repo>@] The top page for the given repo on github.
--
--   [@github::<user>/<repo>/#<nnn>@] Link to a particular issue.
--
--   [@github::<user>/<repo>/\@<hash>@] Link to a particular commit.
--
--   [@post::nnnn@] Link to the blog post with post ID @nnnn@.  Note
--   that this form of special link is invoked when @nnnn@ consists of
--   all digits, so it only works on blogs which use numerical
--   identifiers for post IDs (as Wordpress does).
--
--   [@post::<search>@] Link to the most recent blog post (among the
--   20 most recent posts) containing @<search>@ in its title.
--
--   For example, a post written in Markdown format containing
--
--   @
--       This is a post about the game of [Go](wiki::Go (game)).
--   @
--
--   will be formatted in HTML as
--
--   @
--       <p>This is a post about the game of <a href="https://en.wikipedia.org/wiki/Go%20(game)">Go</a>.</p>
--   @
--
--   You can also create a Transform with your own special link types,
--   using 'mkSpecialLinksXF', and I am happy to receive pull requests
--   adding new types of standard special links.
specialLinksXF :: Transform
specialLinksXF :: Transform
specialLinksXF = [SpecialLink] -> Transform
mkSpecialLinksXF [SpecialLink]
standardSpecialLinks

-- | The standard special link types included in 'specialLinksXF':
--   'luckyLink', 'wikiLink', 'postLink', 'githubLink', and
--   'hackageLink'.
standardSpecialLinks :: [SpecialLink]
standardSpecialLinks :: [SpecialLink]
standardSpecialLinks =
  [ SpecialLink
luckyLink
  , SpecialLink
wikiLink
  , SpecialLink
postLink
  , SpecialLink
githubLink
  , SpecialLink
hackageLink
  ]

-- | A special link consists of two parts:
--
--   * An identifier string.  If the identifier string is @<id>@, this
--   will trigger for links which are of the form @<id>::XXXX@.
--
--   * A URL generation function.  It takes as input the string
--   following the @::@ (the @XXXX@ in the example above), the
--   configuration record, and must output a URL.
--
--   For example,
--
--   @("twitter", \u _ -> return $ "https://twitter.com/" ++ u)@
--
--   is a simple 'SpecialLink' which causes links of the form
--   @twitter::user@ to be replaced by @https://twitter.com/user@.
type SpecialLink = (Text, Text -> BlogLiterately -> IO Text)

-- | Create a transformation which looks for the given special links
--   and replaces them appropriately. You can use this function with
--   your own types of special links.
mkSpecialLinksXF :: [SpecialLink] -> Transform
mkSpecialLinksXF :: [SpecialLink] -> Transform
mkSpecialLinksXF [SpecialLink]
links = (BlogLiterately -> Pandoc -> IO Pandoc)
-> (BlogLiterately -> Bool) -> Transform
ioTransform ([SpecialLink] -> BlogLiterately -> Pandoc -> IO Pandoc
specialLinks [SpecialLink]
links) (Bool -> BlogLiterately -> Bool
forall a b. a -> b -> a
const Bool
True)

-- | Create a document transformation which looks for the given
--   special links and replaces them appropriately.
specialLinks :: [SpecialLink] -> BlogLiterately -> Pandoc -> IO Pandoc
specialLinks :: [SpecialLink] -> BlogLiterately -> Pandoc -> IO Pandoc
specialLinks [SpecialLink]
links BlogLiterately
bl = (Inline -> IO Inline) -> Pandoc -> IO Pandoc
forall (m :: * -> *) a b.
(Monad m, Data a, Data b) =>
(a -> m a) -> b -> m b
bottomUpM Inline -> IO Inline
specialLink
  where
    specialLink :: Inline -> IO Inline
    specialLink :: Inline -> IO Inline
specialLink i :: Inline
i@(Link Attr
attrs [Inline]
alt (Text
url, Text
title))
      | Just (Text
typ, Text
target) <- Text -> Maybe (Text, Text)
getSpecial Text
url
      = Text -> Inline
mkLink (Text -> Inline) -> IO Text -> IO Inline
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Text -> [SpecialLink] -> Maybe (Text -> BlogLiterately -> IO Text)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Text -> Text
T.toLower Text
typ) [SpecialLink]
links of
                     Just Text -> BlogLiterately -> IO Text
mkURL -> Text -> BlogLiterately -> IO Text
mkURL Text
target BlogLiterately
bl
                     Maybe (Text -> BlogLiterately -> IO Text)
Nothing    -> Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
target
      where
        mkLink :: Text -> Inline
mkLink Text
u = Attr -> [Inline] -> (Text, Text) -> Inline
Link Attr
attrs [Inline]
alt (Text
u, Text
title)

    specialLink Inline
i = Inline -> IO Inline
forall (m :: * -> *) a. Monad m => a -> m a
return Inline
i

    getSpecial :: Text -> Maybe (Text, Text)
getSpecial Text
url
      | Text
"::" Text -> Text -> Bool
`T.isInfixOf` Text
url =
          let (Text
typ:[Text]
rest) = Text -> Text -> [Text]
T.splitOn Text
"::" Text
url
          in  (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
typ, Text -> [Text] -> Text
T.intercalate Text
"::" [Text]
rest)
      | Bool
otherwise = Maybe (Text, Text)
forall a. Maybe a
Nothing

-- | Turn @lucky::<search>@ into a link to the first Google result for
-- @<search>@.
luckyLink :: SpecialLink
luckyLink :: SpecialLink
luckyLink = (Text
"lucky", Text -> BlogLiterately -> IO Text
getLucky)
  where
    getLucky :: Text -> BlogLiterately -> IO Text
    getLucky :: Text -> BlogLiterately -> IO Text
getLucky Text
searchTerm BlogLiterately
_ = do
      FilePath
results <- FilePath -> IO FilePath
openURL (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
"http://www.google.com/search?q=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (Text -> FilePath
T.unpack Text
searchTerm)
      let tags :: [Tag FilePath]
tags   = FilePath -> [Tag FilePath]
forall str. StringLike str => str -> [Tag str]
parseTags FilePath
results
          anchor :: [Tag FilePath]
anchor = Int -> [Tag FilePath] -> [Tag FilePath]
forall a. Int -> [a] -> [a]
take Int
1
            ([Tag FilePath] -> [Tag FilePath])
-> ([Tag FilePath] -> [Tag FilePath])
-> [Tag FilePath]
-> [Tag FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tag FilePath -> Bool) -> [Tag FilePath] -> [Tag FilePath]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Tag FilePath -> FilePath -> Bool
forall str t. (StringLike str, TagRep t) => Tag str -> t -> Bool
~/= (FilePath
"<a>" :: String))
            ([Tag FilePath] -> [Tag FilePath])
-> ([Tag FilePath] -> [Tag FilePath])
-> [Tag FilePath]
-> [Tag FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tag FilePath -> Bool) -> [Tag FilePath] -> [Tag FilePath]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Tag FilePath -> FilePath -> Bool
forall str t. (StringLike str, TagRep t) => Tag str -> t -> Bool
~/= (FilePath
"<h3 class='r'>" :: String))
            ([Tag FilePath] -> [Tag FilePath])
-> [Tag FilePath] -> [Tag FilePath]
forall a b. (a -> b) -> a -> b
$ [Tag FilePath]
tags
          url :: Text
url = case [Tag FilePath]
anchor of
            [t :: Tag FilePath
t@(TagOpen{})] -> FilePath -> Text
T.pack (FilePath -> Text)
-> (Tag FilePath -> FilePath) -> Tag FilePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'&') (FilePath -> FilePath)
-> (Tag FilePath -> FilePath) -> Tag FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'h') (FilePath -> FilePath)
-> (Tag FilePath -> FilePath) -> Tag FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Tag FilePath -> FilePath
forall str.
(Show str, Eq str, StringLike str) =>
str -> Tag str -> str
fromAttrib FilePath
"href" (Tag FilePath -> Text) -> Tag FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Tag FilePath
t
            [Tag FilePath]
_ -> Text
searchTerm
      Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
url

-- | Get the contents of the given URL in a simple way.
openURL :: String -> IO String
openURL :: FilePath -> IO FilePath
openURL FilePath
x = Result (Response FilePath) -> IO FilePath
forall ty. Result (Response ty) -> IO ty
getResponseBody (Result (Response FilePath) -> IO FilePath)
-> IO (Result (Response FilePath)) -> IO FilePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Request FilePath -> IO (Result (Response FilePath))
forall ty. HStream ty => Request ty -> IO (Result (Response ty))
simpleHTTP (FilePath -> Request FilePath
getRequest FilePath
x)

-- | Given @wiki::<title>@, generate a link to the Wikipedia page for
--   @<title>@.  Note that the page is not checked for existence.
wikiLink :: SpecialLink
wikiLink :: SpecialLink
wikiLink = (Text
"wiki", \Text
target BlogLiterately
_ -> Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
T.append Text
"https://en.wikipedia.org/wiki/" Text
target)

-- | @postLink@ handles two types of special links.
--
-- [@post::nnnn@] Link to the blog post with post ID @nnnn@.  Note that
-- this form of special link is invoked when @nnnn@ consists of all
-- digits, so it only works on blogs which use numerical identifiers
-- for post IDs (as Wordpress does).
--
-- [@post::<search>@] Link to the most recent blog post (among the
-- 20 most recent posts) containing @<search>@ in its title.
postLink :: SpecialLink
postLink :: SpecialLink
postLink = (Text
"post", Text -> BlogLiterately -> IO Text
getPostLink)
  where
    getPostLink :: Text -> BlogLiterately -> IO Text
    getPostLink :: Text -> BlogLiterately -> IO Text
getPostLink Text
target BlogLiterately
bl =
      (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
target (Maybe Text -> Text)
-> (Maybe FilePath -> Maybe Text) -> Maybe FilePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Text) -> Maybe FilePath -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Text
T.pack) (Maybe FilePath -> Text) -> IO (Maybe FilePath) -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        case ((Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isDigit Text
target, BlogLiterately
bl BlogLiterately
-> Getting (Maybe FilePath) BlogLiterately (Maybe FilePath)
-> Maybe FilePath
forall s a. s -> Getting a s a -> a
^. Getting (Maybe FilePath) BlogLiterately (Maybe FilePath)
Lens' BlogLiterately (Maybe FilePath)
blog) of
          (Bool
_    , Maybe FilePath
Nothing ) -> Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing
          (Bool
True , Just FilePath
url) -> FilePath -> FilePath -> FilePath -> FilePath -> IO (Maybe FilePath)
getPostURL FilePath
url (Text -> FilePath
T.unpack Text
target) (BlogLiterately -> FilePath
user' BlogLiterately
bl) (BlogLiterately -> FilePath
password' BlogLiterately
bl)
          (Bool
False, Just FilePath
url) -> Int
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> IO (Maybe FilePath)
findTitle Int
20 FilePath
url (Text -> FilePath
T.unpack Text
target) (BlogLiterately -> FilePath
user' BlogLiterately
bl) (BlogLiterately -> FilePath
password' BlogLiterately
bl)

          -- If all digits, replace with permalink for that postid
          -- Otherwise, search titles of 20 most recent posts.
          --   Choose most recent that matches.

-- | @githubLink@ handles several types of special links.
--
-- [@github::<user>/<repo>@] links to a repository.
--
-- [@github::<user>/<repo>/#<nnn>@] links to issue #nnn.
--
-- [@github::<user>/<repo>/\@<hash>@] links to the commit with the
-- given hash.
githubLink :: SpecialLink
githubLink :: SpecialLink
githubLink = (Text
"github", Text -> BlogLiterately -> IO Text
getGithubLink)
  where
    getGithubLink :: Text -> BlogLiterately -> IO Text
    getGithubLink :: Text -> BlogLiterately -> IO Text
getGithubLink Text
target BlogLiterately
bl = Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> IO Text) -> (FilePath -> Text) -> FilePath -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack (FilePath -> IO Text) -> FilePath -> IO Text
forall a b. (a -> b) -> a -> b
$
      case FilePath -> FilePath -> [FilePath]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn FilePath
"/" (Text -> FilePath
T.unpack Text
target) of
        (FilePath
user : FilePath
repo : [FilePath]
ghTarget) -> FilePath
github FilePath -> FilePath -> FilePath
</> FilePath
user FilePath -> FilePath -> FilePath
</> FilePath
repo FilePath -> FilePath -> FilePath
</> [FilePath] -> FilePath
mkTarget [FilePath]
ghTarget
        [FilePath]
_ -> FilePath
github FilePath -> FilePath -> FilePath
</> (Text -> FilePath
T.unpack Text
target)
    github :: FilePath
github = FilePath
"https://github.com/"
    mkTarget :: [FilePath] -> FilePath
mkTarget []                 = FilePath
""
    mkTarget ((Char
'@': FilePath
hash) : [FilePath]
_)  = FilePath
"commit" FilePath -> FilePath -> FilePath
</> FilePath
hash
    mkTarget ((Char
'#': FilePath
issue) : [FilePath]
_) = FilePath
"issues" FilePath -> FilePath -> FilePath
</> FilePath
issue

-- | A target of the form @hackage::<pkg>@ turns into a link to the
--   package @<pkg>@ on Hackage.
hackageLink :: SpecialLink
hackageLink :: SpecialLink
hackageLink = (Text
"hackage", Text -> BlogLiterately -> IO Text
getHackageLink)
  where
    getHackageLink :: Text -> BlogLiterately -> IO Text
    getHackageLink :: Text -> BlogLiterately -> IO Text
getHackageLink Text
pkg BlogLiterately
bl = Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
T.append Text
hackagePrefix Text
pkg
    hackagePrefix :: Text
hackagePrefix = Text
"http://hackage.haskell.org/package/"

-- | Potentially extract a title from the metadata block, and set it
--   in the options record.
titleXF :: Transform
titleXF :: Transform
titleXF = StateT (BlogLiterately, Pandoc) PandocIO ()
-> (BlogLiterately -> Bool) -> Transform
Transform StateT (BlogLiterately, Pandoc) PandocIO ()
extractTitle (Bool -> BlogLiterately -> Bool
forall a b. a -> b -> a
const Bool
True)
  where
    extractTitle :: StateT (BlogLiterately, Pandoc) PandocIO ()
extractTitle = do
      (Pandoc (Meta Map Text MetaValue
m) [Block]
_) <- ((BlogLiterately, Pandoc) -> Pandoc)
-> StateT (BlogLiterately, Pandoc) PandocIO Pandoc
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (BlogLiterately, Pandoc) -> Pandoc
forall a b. (a, b) -> b
snd
      case Text -> Map Text MetaValue -> Maybe MetaValue
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
"title" Map Text MetaValue
m of
        Just (MetaString Text
s) ->
          FilePath -> StateT (BlogLiterately, Pandoc) PandocIO ()
forall s (m :: * -> *).
(MonadState s m, Field1 s s BlogLiterately BlogLiterately) =>
FilePath -> m ()
setTitle (Text -> FilePath
T.unpack Text
s)
        Just (MetaInlines [Inline]
is) ->
          FilePath -> StateT (BlogLiterately, Pandoc) PandocIO ()
forall s (m :: * -> *).
(MonadState s m, Field1 s s BlogLiterately BlogLiterately) =>
FilePath -> m ()
setTitle (FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
" " [Text -> FilePath
T.unpack Text
s | Str Text
s <- [Inline]
is])
        Maybe MetaValue
_ -> () -> StateT (BlogLiterately, Pandoc) PandocIO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- title set explicitly with --title takes precedence.
    setTitle :: FilePath -> m ()
setTitle FilePath
s = (BlogLiterately -> Identity BlogLiterately) -> s -> Identity s
forall s t a b. Field1 s t a b => Lens s t a b
_1((BlogLiterately -> Identity BlogLiterately) -> s -> Identity s)
-> ((Maybe FilePath -> Identity (Maybe FilePath))
    -> BlogLiterately -> Identity BlogLiterately)
-> (Maybe FilePath -> Identity (Maybe FilePath))
-> s
-> Identity s
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Maybe FilePath -> Identity (Maybe FilePath))
-> BlogLiterately -> Identity BlogLiterately
Lens' BlogLiterately (Maybe FilePath)
title ((Maybe FilePath -> Identity (Maybe FilePath)) -> s -> Identity s)
-> (Maybe FilePath -> Maybe FilePath) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (Maybe FilePath -> Maybe FilePath -> Maybe FilePath
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
s)

-- | Extract blocks tagged with @[BLOpts]@ and use their contents as
--   options.
optionsXF :: Transform
optionsXF :: Transform
optionsXF = StateT (BlogLiterately, Pandoc) PandocIO ()
-> (BlogLiterately -> Bool) -> Transform
Transform StateT (BlogLiterately, Pandoc) PandocIO ()
optionsXF' (Bool -> BlogLiterately -> Bool
forall a b. a -> b -> a
const Bool
True)
  where
    optionsXF' :: StateT (BlogLiterately, Pandoc) PandocIO ()
optionsXF' = do
      ([ParseError]
errs, BlogLiterately
opts) <- (Block -> ([ParseError], BlogLiterately))
-> Pandoc -> ([ParseError], BlogLiterately)
forall a b c. (Data a, Monoid b, Data c) => (a -> b) -> c -> b
queryWith Block -> ([ParseError], BlogLiterately)
extractOptions (Pandoc -> ([ParseError], BlogLiterately))
-> StateT (BlogLiterately, Pandoc) PandocIO Pandoc
-> StateT
     (BlogLiterately, Pandoc) PandocIO ([ParseError], BlogLiterately)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((BlogLiterately, Pandoc) -> Pandoc)
-> StateT (BlogLiterately, Pandoc) PandocIO Pandoc
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (BlogLiterately, Pandoc) -> Pandoc
forall a b. (a, b) -> b
snd
      (ParseError -> StateT (BlogLiterately, Pandoc) PandocIO ())
-> [ParseError] -> StateT (BlogLiterately, Pandoc) PandocIO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IO () -> StateT (BlogLiterately, Pandoc) PandocIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT (BlogLiterately, Pandoc) PandocIO ())
-> (ParseError -> IO ())
-> ParseError
-> StateT (BlogLiterately, Pandoc) PandocIO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> IO ()
forall a. Show a => a -> IO ()
print) [ParseError]
errs
      (BlogLiterately -> Identity BlogLiterately)
-> (BlogLiterately, Pandoc) -> Identity (BlogLiterately, Pandoc)
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((BlogLiterately -> Identity BlogLiterately)
 -> (BlogLiterately, Pandoc) -> Identity (BlogLiterately, Pandoc))
-> (BlogLiterately -> BlogLiterately)
-> StateT (BlogLiterately, Pandoc) PandocIO ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (BlogLiterately -> BlogLiterately -> BlogLiterately
forall a. Semigroup a => a -> a -> a
<> BlogLiterately
opts)
      (Pandoc -> Identity Pandoc)
-> (BlogLiterately, Pandoc) -> Identity (BlogLiterately, Pandoc)
forall s t a b. Field2 s t a b => Lens s t a b
_2 ((Pandoc -> Identity Pandoc)
 -> (BlogLiterately, Pandoc) -> Identity (BlogLiterately, Pandoc))
-> (Pandoc -> Pandoc)
-> StateT (BlogLiterately, Pandoc) PandocIO ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (Block -> Block) -> Pandoc -> Pandoc
forall a b. (Data a, Data b) => (a -> a) -> b -> b
bottomUp Block -> Block
killOptionBlocks

-- | 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 :: Block -> ([ParseError], BlogLiterately)
extractOptions = Text
-> (Attr -> Text -> ([ParseError], BlogLiterately))
-> (Block -> ([ParseError], BlogLiterately))
-> Block
-> ([ParseError], BlogLiterately)
forall a. Text -> (Attr -> Text -> a) -> (Block -> a) -> Block -> a
onTag Text
"blopts" ((Text -> ([ParseError], BlogLiterately))
-> Attr -> Text -> ([ParseError], BlogLiterately)
forall a b. a -> b -> a
const (FilePath -> ([ParseError], BlogLiterately)
readBLOptions (FilePath -> ([ParseError], BlogLiterately))
-> (Text -> FilePath) -> Text -> ([ParseError], BlogLiterately)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack)) (([ParseError], BlogLiterately)
-> Block -> ([ParseError], BlogLiterately)
forall a b. a -> b -> a
const ([ParseError], BlogLiterately)
forall a. Monoid a => a
mempty)

-- | Delete any blocks tagged with @[BLOpts]@.
killOptionBlocks :: Block -> Block
killOptionBlocks :: Block -> Block
killOptionBlocks = Text
-> (Attr -> Text -> Block) -> (Block -> Block) -> Block -> Block
forall a. Text -> (Attr -> Text -> a) -> (Block -> a) -> Block -> a
onTag Text
"blopts" ((Text -> Block) -> Attr -> Text -> Block
forall a b. a -> b -> a
const (Block -> Text -> Block
forall a b. a -> b -> a
const Block
Null)) Block -> Block
forall a. a -> a
id

-- | Prompt the user for a password if the @blog@ field is set but no
--   password has been provided.
passwordXF :: Transform
passwordXF :: Transform
passwordXF = StateT (BlogLiterately, Pandoc) PandocIO ()
-> (BlogLiterately -> Bool) -> Transform
Transform StateT (BlogLiterately, Pandoc) PandocIO ()
passwordPrompt BlogLiterately -> Bool
passwordCond
  where
    passwordCond :: BlogLiterately -> Bool
passwordCond BlogLiterately
bl = ((BlogLiterately
bl BlogLiterately
-> Getting (Maybe FilePath) BlogLiterately (Maybe FilePath)
-> Maybe FilePath
forall s a. s -> Getting a s a -> a
^. Getting (Maybe FilePath) BlogLiterately (Maybe FilePath)
Lens' BlogLiterately (Maybe FilePath)
blog)     Maybe FilePath -> (Maybe FilePath -> Bool) -> Bool
forall a b. a -> (a -> b) -> b
& Getting Any (Maybe FilePath) FilePath -> Maybe FilePath -> Bool
forall s a. Getting Any s a -> s -> Bool
has   Getting Any (Maybe FilePath) FilePath
forall a b. Prism (Maybe a) (Maybe b) a b
_Just)
                   Bool -> Bool -> Bool
&& ((BlogLiterately
bl BlogLiterately
-> Getting (Maybe FilePath) BlogLiterately (Maybe FilePath)
-> Maybe FilePath
forall s a. s -> Getting a s a -> a
^. Getting (Maybe FilePath) BlogLiterately (Maybe FilePath)
Lens' BlogLiterately (Maybe FilePath)
password) Maybe FilePath -> (Maybe FilePath -> Bool) -> Bool
forall a b. a -> (a -> b) -> b
& APrism (Maybe FilePath) (Maybe Any) FilePath Any
-> Maybe FilePath -> Bool
forall s t a b. APrism s t a b -> s -> Bool
isn't APrism (Maybe FilePath) (Maybe Any) FilePath Any
forall a b. Prism (Maybe a) (Maybe b) a b
_Just)
    passwordPrompt :: StateT (BlogLiterately, Pandoc) PandocIO ()
passwordPrompt  = do
      IO () -> StateT (BlogLiterately, Pandoc) PandocIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT (BlogLiterately, Pandoc) PandocIO ())
-> IO () -> StateT (BlogLiterately, Pandoc) PandocIO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
putStr FilePath
"Password: " IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout
      FilePath
pwd <- IO FilePath -> StateT (BlogLiterately, Pandoc) PandocIO FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getLine
      (BlogLiterately -> Identity BlogLiterately)
-> (BlogLiterately, Pandoc) -> Identity (BlogLiterately, Pandoc)
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((BlogLiterately -> Identity BlogLiterately)
 -> (BlogLiterately, Pandoc) -> Identity (BlogLiterately, Pandoc))
-> ((Maybe FilePath -> Identity (Maybe FilePath))
    -> BlogLiterately -> Identity BlogLiterately)
-> (Maybe FilePath -> Identity (Maybe FilePath))
-> (BlogLiterately, Pandoc)
-> Identity (BlogLiterately, Pandoc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe FilePath -> Identity (Maybe FilePath))
-> BlogLiterately -> Identity BlogLiterately
Lens' BlogLiterately (Maybe FilePath)
password ((Maybe FilePath -> Identity (Maybe FilePath))
 -> (BlogLiterately, Pandoc) -> Identity (BlogLiterately, Pandoc))
-> Maybe FilePath -> StateT (BlogLiterately, Pandoc) PandocIO ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
pwd

-- | Read a user-supplied style file and add its contents to the
--   highlighting options.
highlightOptsXF :: Transform
highlightOptsXF :: Transform
highlightOptsXF = StateT (BlogLiterately, Pandoc) PandocIO ()
-> (BlogLiterately -> Bool) -> Transform
Transform StateT (BlogLiterately, Pandoc) PandocIO ()
doHighlightOptsXF (Bool -> BlogLiterately -> Bool
forall a b. a -> b -> a
const Bool
True)
  where
    doHighlightOptsXF :: StateT (BlogLiterately, Pandoc) PandocIO ()
doHighlightOptsXF = do
      StylePrefs
prefs <- (IO StylePrefs
-> StateT (BlogLiterately, Pandoc) PandocIO StylePrefs
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO StylePrefs
 -> StateT (BlogLiterately, Pandoc) PandocIO StylePrefs)
-> (Maybe FilePath -> IO StylePrefs)
-> Maybe FilePath
-> StateT (BlogLiterately, Pandoc) PandocIO StylePrefs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe FilePath -> IO StylePrefs
getStylePrefs) (Maybe FilePath
 -> StateT (BlogLiterately, Pandoc) PandocIO StylePrefs)
-> StateT (BlogLiterately, Pandoc) PandocIO (Maybe FilePath)
-> StateT (BlogLiterately, Pandoc) PandocIO StylePrefs
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Getting (Maybe FilePath) (BlogLiterately, Pandoc) (Maybe FilePath)
-> StateT (BlogLiterately, Pandoc) PandocIO (Maybe FilePath)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use ((BlogLiterately -> Const (Maybe FilePath) BlogLiterately)
-> (BlogLiterately, Pandoc)
-> Const (Maybe FilePath) (BlogLiterately, Pandoc)
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((BlogLiterately -> Const (Maybe FilePath) BlogLiterately)
 -> (BlogLiterately, Pandoc)
 -> Const (Maybe FilePath) (BlogLiterately, Pandoc))
-> Getting (Maybe FilePath) BlogLiterately (Maybe FilePath)
-> Getting
     (Maybe FilePath) (BlogLiterately, Pandoc) (Maybe FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Maybe FilePath) BlogLiterately (Maybe FilePath)
Lens' BlogLiterately (Maybe FilePath)
style)
      ((BlogLiterately -> Identity BlogLiterately)
-> (BlogLiterately, Pandoc) -> Identity (BlogLiterately, Pandoc)
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((BlogLiterately -> Identity BlogLiterately)
 -> (BlogLiterately, Pandoc) -> Identity (BlogLiterately, Pandoc))
-> ((Maybe HsHighlight -> Identity (Maybe HsHighlight))
    -> BlogLiterately -> Identity BlogLiterately)
-> (Maybe HsHighlight -> Identity (Maybe HsHighlight))
-> (BlogLiterately, Pandoc)
-> Identity (BlogLiterately, Pandoc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe HsHighlight -> Identity (Maybe HsHighlight))
-> BlogLiterately -> Identity BlogLiterately
Lens' BlogLiterately (Maybe HsHighlight)
hsHighlight) ((Maybe HsHighlight -> Identity (Maybe HsHighlight))
 -> (BlogLiterately, Pandoc) -> Identity (BlogLiterately, Pandoc))
-> (Maybe HsHighlight -> Maybe HsHighlight)
-> StateT (BlogLiterately, Pandoc) PandocIO ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= HsHighlight -> Maybe HsHighlight
forall a. a -> Maybe a
Just (HsHighlight -> Maybe HsHighlight)
-> (Maybe HsHighlight -> HsHighlight)
-> Maybe HsHighlight
-> Maybe HsHighlight
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsHighlight
-> (HsHighlight -> HsHighlight) -> Maybe HsHighlight -> HsHighlight
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (StylePrefs -> HsHighlight
HsColourInline StylePrefs
prefs)
                                         ((StylePrefs -> Identity StylePrefs)
-> HsHighlight -> Identity HsHighlight
Prism' HsHighlight StylePrefs
_HsColourInline ((StylePrefs -> Identity StylePrefs)
 -> HsHighlight -> Identity HsHighlight)
-> StylePrefs -> HsHighlight -> HsHighlight
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StylePrefs
prefs)

-- | Format citations.
citationsXF :: Transform
citationsXF :: Transform
citationsXF = (BlogLiterately -> Pandoc -> PandocIO Pandoc)
-> (BlogLiterately -> Bool) -> Transform
pioTransform ((Pandoc -> PandocIO Pandoc)
-> BlogLiterately -> Pandoc -> PandocIO Pandoc
forall a b. a -> b -> a
const Pandoc -> PandocIO Pandoc
forall (m :: * -> *). PandocMonad m => Pandoc -> m Pandoc
processCitations) BlogLiterately -> Bool
citations'

-- | Load options from a profile if one is specified.
profileXF :: Transform
profileXF :: Transform
profileXF = StateT (BlogLiterately, Pandoc) PandocIO ()
-> (BlogLiterately -> Bool) -> Transform
Transform StateT (BlogLiterately, Pandoc) PandocIO ()
doProfileXF (Bool -> BlogLiterately -> Bool
forall a b. a -> b -> a
const Bool
True)
  where
    doProfileXF :: StateT (BlogLiterately, Pandoc) PandocIO ()
doProfileXF = do
      BlogLiterately
bl  <- Getting BlogLiterately (BlogLiterately, Pandoc) BlogLiterately
-> StateT (BlogLiterately, Pandoc) PandocIO BlogLiterately
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting BlogLiterately (BlogLiterately, Pandoc) BlogLiterately
forall s t a b. Field1 s t a b => Lens s t a b
_1
      BlogLiterately
bl' <- IO BlogLiterately
-> StateT (BlogLiterately, Pandoc) PandocIO BlogLiterately
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO BlogLiterately
 -> StateT (BlogLiterately, Pandoc) PandocIO BlogLiterately)
-> IO BlogLiterately
-> StateT (BlogLiterately, Pandoc) PandocIO BlogLiterately
forall a b. (a -> b) -> a -> b
$ BlogLiterately -> IO BlogLiterately
loadProfile BlogLiterately
bl
      (BlogLiterately -> Identity BlogLiterately)
-> (BlogLiterately, Pandoc) -> Identity (BlogLiterately, Pandoc)
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((BlogLiterately -> Identity BlogLiterately)
 -> (BlogLiterately, Pandoc) -> Identity (BlogLiterately, Pandoc))
-> BlogLiterately -> StateT (BlogLiterately, Pandoc) PandocIO ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= BlogLiterately
bl'

-- | Load additional options from a profile specified in the options
--   record.
loadProfile :: BlogLiterately -> IO BlogLiterately
loadProfile :: BlogLiterately -> IO BlogLiterately
loadProfile BlogLiterately
bl =
  case BlogLiterately
blBlogLiterately
-> Getting (Maybe FilePath) BlogLiterately (Maybe FilePath)
-> Maybe FilePath
forall s a. s -> Getting a s a -> a
^.Getting (Maybe FilePath) BlogLiterately (Maybe FilePath)
Lens' BlogLiterately (Maybe FilePath)
profile of
    Maybe FilePath
Nothing          -> BlogLiterately -> IO BlogLiterately
forall (m :: * -> *) a. Monad m => a -> m a
return BlogLiterately
bl
    Just FilePath
profileName -> do
      FilePath
appDir <- FilePath -> IO FilePath
getAppUserDataDirectory FilePath
"BlogLiterately"

      let profileCfg :: FilePath
profileCfg = FilePath
appDir FilePath -> FilePath -> FilePath
</> FilePath
profileName FilePath -> FilePath -> FilePath
<.> FilePath
"cfg"
      Bool
e <- FilePath -> IO Bool
doesFileExist FilePath
profileCfg
      case Bool
e of
        Bool
False -> do
          FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
profileCfg FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": file not found"
          IO BlogLiterately
forall a. IO a
exitFailure
        Bool
True  -> do
          ([ParseError]
errs, BlogLiterately
blProfile) <- FilePath -> ([ParseError], BlogLiterately)
readBLOptions (FilePath -> ([ParseError], BlogLiterately))
-> IO FilePath -> IO ([ParseError], BlogLiterately)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO FilePath
readFile FilePath
profileCfg
          (ParseError -> IO ()) -> [ParseError] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ParseError -> IO ()
forall a. Show a => a -> IO ()
print [ParseError]
errs
          BlogLiterately -> IO BlogLiterately
forall (m :: * -> *) a. Monad m => a -> m a
return (BlogLiterately -> IO BlogLiterately)
-> BlogLiterately -> IO BlogLiterately
forall a b. (a -> b) -> a -> b
$ BlogLiterately -> BlogLiterately -> BlogLiterately
forall a. Monoid a => a -> a -> a
mappend BlogLiterately
blProfile BlogLiterately
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
--
--   * 'rawtexifyXF': pass LaTeX through unchanged
--
--   * '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
--
--   * 'specialLinksXF': replace special link types with URLs
--
--   * 'highlightOptsXF': load the requested highlighting style file
--
--   * 'highlightXF': perform syntax highlighting
--
--   * 'citationsXF': process citations
standardTransforms :: [Transform]
standardTransforms :: [Transform]
standardTransforms =
  [ -- Has to go first, since it may affect later transforms.
    Transform
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.
  , Transform
profileXF

    -- The order of the rest of these probably doesn't matter that
    -- much, except highlightOptsXF should go before highlightXF.
  , Transform
passwordXF
  , Transform
titleXF
  , Transform
rawtexifyXF
  , Transform
wptexifyXF
  , Transform
ghciXF
  , Transform
uploadImagesXF
  , Transform
centerImagesXF
  , Transform
specialLinksXF
  , Transform
highlightOptsXF
  , Transform
highlightXF
  , Transform
citationsXF
  ]

--------------------------------------------------
-- Transforming documents
--------------------------------------------------

-- | Transform a complete input document string to an HTML output
--   string, given a list of transformation passes.
xformDoc :: BlogLiterately -> [Transform] -> String -> IO (Either PandocError (BlogLiterately, String))
xformDoc :: BlogLiterately
-> [Transform]
-> FilePath
-> IO (Either PandocError (BlogLiterately, FilePath))
xformDoc BlogLiterately
bl [Transform]
xforms FilePath
s = do
  Right Template Text
tpl <- FilePath -> Text -> IO (Either FilePath (Template Text))
forall (m :: * -> *) a.
(TemplateMonad m, TemplateTarget a) =>
FilePath -> Text -> m (Either FilePath (Template a))
compileTemplate FilePath
"" Text
blHtmlTemplate
  PandocIO (BlogLiterately, FilePath)
-> IO (Either PandocError (BlogLiterately, FilePath))
forall a. PandocIO a -> IO (Either PandocError a)
runIO (PandocIO (BlogLiterately, FilePath)
 -> IO (Either PandocError (BlogLiterately, FilePath)))
-> (FilePath -> PandocIO (BlogLiterately, FilePath))
-> FilePath
-> IO (Either PandocError (BlogLiterately, FilePath))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (     FilePath -> FilePath
fixLineEndings
      (FilePath -> FilePath)
-> (FilePath -> PandocIO (BlogLiterately, FilePath))
-> FilePath
-> PandocIO (BlogLiterately, FilePath)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> FilePath -> Text
T.pack
      (FilePath -> Text)
-> (Text -> PandocIO (BlogLiterately, FilePath))
-> FilePath
-> PandocIO (BlogLiterately, FilePath)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ReaderOptions -> Text -> PandocIO Pandoc
parseFile ReaderOptions
parseOpts
      (Text -> PandocIO Pandoc)
-> (Pandoc -> PandocIO (BlogLiterately, FilePath))
-> Text
-> PandocIO (BlogLiterately, FilePath)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> [Transform]
-> BlogLiterately -> Pandoc -> PandocIO (BlogLiterately, Pandoc)
runTransforms [Transform]
xforms BlogLiterately
bl
      (Pandoc -> PandocIO (BlogLiterately, Pandoc))
-> ((BlogLiterately, Pandoc)
    -> PandocIO (BlogLiterately, FilePath))
-> Pandoc
-> PandocIO (BlogLiterately, FilePath)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (\(BlogLiterately
bl', Pandoc
p) -> (BlogLiterately
bl',) (Text -> (BlogLiterately, Text))
-> PandocIO Text -> PandocIO (BlogLiterately, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterOptions -> Pandoc -> PandocIO Text
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeHtml5String (BlogLiterately -> Template Text -> WriterOptions
writeOpts BlogLiterately
bl' Template Text
tpl) Pandoc
p)
      ((BlogLiterately, Pandoc) -> PandocIO (BlogLiterately, Text))
-> ((BlogLiterately, Text) -> PandocIO (BlogLiterately, FilePath))
-> (BlogLiterately, Pandoc)
-> PandocIO (BlogLiterately, FilePath)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (Text -> PandocIO FilePath)
-> (BlogLiterately, Text) -> PandocIO (BlogLiterately, FilePath)
forall s t a b. Field2 s t a b => Lens s t a b
_2 (FilePath -> PandocIO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> PandocIO FilePath)
-> (Text -> FilePath) -> Text -> PandocIO FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack)
    )
    (FilePath -> IO (Either PandocError (BlogLiterately, FilePath)))
-> FilePath -> IO (Either PandocError (BlogLiterately, FilePath))
forall a b. (a -> b) -> a -> b
$ FilePath
s
  where
    parseFile :: ReaderOptions -> Text -> PandocIO Pandoc
    parseFile :: ReaderOptions -> Text -> PandocIO Pandoc
parseFile ReaderOptions
opts =
      case BlogLiterately
blBlogLiterately
-> Getting (Maybe FilePath) BlogLiterately (Maybe FilePath)
-> Maybe FilePath
forall s a. s -> Getting a s a -> a
^.Getting (Maybe FilePath) BlogLiterately (Maybe FilePath)
Lens' BlogLiterately (Maybe FilePath)
format of
        Just FilePath
"rst"      -> ReaderOptions -> Text -> PandocIO Pandoc
forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readRST      ReaderOptions
opts
        Just FilePath
_          -> ReaderOptions -> Text -> PandocIO Pandoc
forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readMarkdown ReaderOptions
opts
        Maybe FilePath
Nothing         ->
          case FilePath -> FilePath
takeExtension (BlogLiterately -> FilePath
file' BlogLiterately
bl) of
            FilePath
".rst"  -> ReaderOptions -> Text -> PandocIO Pandoc
forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readRST ReaderOptions
opts
            FilePath
".rest" -> ReaderOptions -> Text -> PandocIO Pandoc
forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readRST ReaderOptions
opts
            FilePath
".txt"  -> ReaderOptions -> Text -> PandocIO Pandoc
forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readRST ReaderOptions
opts
            FilePath
_       -> ReaderOptions -> Text -> PandocIO Pandoc
forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readMarkdown ReaderOptions
opts

    parseOpts :: ReaderOptions
parseOpts = ReaderOptions
forall a. Default a => a
def
      { readerExtensions :: Extensions
readerExtensions = Extensions
pandocExtensions Extensions -> (Extensions -> Extensions) -> Extensions
forall a b. a -> (a -> b) -> b
&
          ((Extensions -> Extensions)
 -> (Extensions -> Extensions) -> Extensions -> Extensions)
-> (Extensions -> Extensions)
-> [Extensions -> Extensions]
-> Extensions
-> Extensions
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Extensions -> Extensions)
-> (Extensions -> Extensions) -> Extensions -> Extensions
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) Extensions -> Extensions
forall a. a -> a
id
            [ Extension -> Extensions -> Extensions
enableExtension Extension
Ext_tex_math_single_backslash
            , case BlogLiterately
blBlogLiterately
-> Getting (Maybe Bool) BlogLiterately (Maybe Bool) -> Maybe Bool
forall s a. s -> Getting a s a -> a
^.Getting (Maybe Bool) BlogLiterately (Maybe Bool)
Lens' BlogLiterately (Maybe Bool)
litHaskell of
                Just Bool
False -> Extensions -> Extensions
forall a. a -> a
id
                Maybe Bool
_          -> Extension -> Extensions -> Extensions
enableExtension Extension
Ext_literate_haskell
            ]

            -- Relevant extensions enabled by default in pandocExtensions:
            -- (see https://hackage.haskell.org/package/pandoc-2.1.1/docs/src/Text-Pandoc-Extensions.html#pandocExtensions):

            -- Ext_smart
            -- Ext_yaml_metadata_block
            -- Ext_tex_math_dollars
            -- Ext_pandoc_title_block
            -- Ext_citations
      }
    writeOpts :: BlogLiterately -> Template Text -> WriterOptions
writeOpts BlogLiterately
bl Template Text
tpl = WriterOptions
forall a. Default a => a
def
      { writerReferenceLinks :: Bool
writerReferenceLinks  = Bool
True
      , writerTableOfContents :: Bool
writerTableOfContents = BlogLiterately -> Bool
toc' BlogLiterately
bl
      , writerHTMLMathMethod :: HTMLMathMethod
writerHTMLMathMethod  =
          case BlogLiterately -> FilePath
math' BlogLiterately
bl of
            FilePath
""  -> HTMLMathMethod
PlainMath
            FilePath
opt -> Text -> HTMLMathMethod
mathOption (FilePath -> Text
T.pack FilePath
opt)
      , writerTemplate :: Maybe (Template Text)
writerTemplate        = Template Text -> Maybe (Template Text)
forall a. a -> Maybe a
Just Template Text
tpl
      }

    mathOption :: Text -> HTMLMathMethod
mathOption Text
opt
      | Text
opt Text -> Text -> Bool
`T.isPrefixOf` Text
"mathml"      = HTMLMathMethod
MathML
      | Text
opt Text -> Text -> Bool
`T.isPrefixOf` Text
"mimetex"     =
          Text -> HTMLMathMethod
WebTeX (Text -> Text -> Text
mathUrl Text
"/cgi-bin/mimetex.cgi?" Text
opt)
      | Text
opt Text -> Text -> Bool
`T.isPrefixOf` Text
"webtex"      = Text -> HTMLMathMethod
WebTeX (Text -> Text -> Text
mathUrl Text
webTeXURL Text
opt)
      | Text
opt Text -> Text -> Bool
`T.isPrefixOf` Text
"mathjax"     = Text -> HTMLMathMethod
MathJax (Text -> Text -> Text
mathUrl Text
mathJaxURL Text
opt)
      | Bool
otherwise                      = HTMLMathMethod
PlainMath

    webTeXURL :: Text
webTeXURL  = Text
"http://chart.apis.google.com/chart?cht=tx&chl="
    mathJaxURL :: Text
mathJaxURL = Text -> Text -> Text
T.append Text
"http://cdn.mathjax.org/mathjax/latest/MathJax.js"
                   Text
"?config=TeX-AMS-MML_HTMLorMML"

    urlPart :: Text -> Text
    urlPart :: Text -> Text
urlPart = Int -> Text -> Text
T.drop Int
1 (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'=')

    mathUrl :: Text -> Text -> Text
mathUrl Text
dflt Text
opt  = case Text -> Text
urlPart Text
opt of Text
"" -> Text
dflt; Text
x -> Text
x

-- | Turn @CRLF@ pairs into a single @LF@.  This is necessary since
--   'readMarkdown' is picky about line endings.
fixLineEndings :: String -> String
fixLineEndings :: FilePath -> FilePath
fixLineEndings []             = []
fixLineEndings (Char
'\r':Char
'\n':FilePath
cs) = Char
'\n'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath -> FilePath
fixLineEndings FilePath
cs
fixLineEndings (Char
c:FilePath
cs)         = Char
cChar -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath -> FilePath
fixLineEndings FilePath
cs

-- We use a special template with the "standalone" pandoc writer.  We
-- don't actually want truly "standalone" HTML documents because they
-- have to sit inside another web page.  But we do want things like
-- math typesetting and a table of contents.
blHtmlTemplate :: Text
blHtmlTemplate = [Text] -> Text
T.unlines
  [ Text
"$if(highlighting-css)$"
  , Text
"  <style type=\"text/css\">"
  , Text
"$highlighting-css$"
  , Text
"  </style>"
  , Text
"$endif$"
  , Text
"$for(css)$"
  , Text
"  <link rel=\"stylesheet\" href=\"$css$\" $if(html5)$$else$type=\"text/css\" $endif$/>"
  , Text
"$endfor$"
  , Text
"$if(math)$"
  , Text
"  $math$"
  , Text
"$endif$"
  , Text
"$if(toc)$"
  , Text
"<div id=\"$idprefix$TOC\">"
  , Text
"$toc$"
  , Text
"</div>"
  , Text
"$endif$"
  , Text
"$body$"
  ]