{-# 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, 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 (forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a, b) -> a
fst forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \BlogLiterately
bl -> forall s t a b. Field2 s t a b => Lens s t a b
_2 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 -> 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 forall a b. (a -> b) -> a -> b
$ do
  (BlogLiterately
bl,Pandoc
p) <- forall s (m :: * -> *). MonadState s m => m s
get
  Pandoc
p' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ BlogLiterately -> Pandoc -> PandocIO Pandoc
transf BlogLiterately
bl Pandoc
p
  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 <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a, b) -> a
fst
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Transform -> BlogLiterately -> Bool
xfCond Transform
t BlogLiterately
bl) 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 = forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (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 (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 (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 (String -> Pandoc -> IO Pandoc
formatInlineGhci forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlogLiterately -> String
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))
  (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 (forall a b. a -> b -> a
const Pandoc -> Pandoc
centerImages) (forall a b. a -> b -> a
const Bool
True)

centerImages :: Pandoc -> Pandoc
centerImages :: Pandoc -> Pandoc
centerImages = 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;\">"
      forall a. a -> [a] -> [a]
: Block
img
      forall a. a -> [a] -> [a]
: Format -> Text -> Block
RawBlock (Text -> Format
Format Text
"html") Text
"</div>"
      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) (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 = 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case 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    -> 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 = 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  forall a. a -> Maybe a
Just (Text
typ, Text -> [Text] -> Text
T.intercalate Text
"::" [Text]
rest)
      | Bool
otherwise = 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
      String
results <- String -> IO String
openURL forall a b. (a -> b) -> a -> b
$ String
"http://www.google.com/search?q=" forall a. [a] -> [a] -> [a]
++ (Text -> String
T.unpack Text
searchTerm)
      let tags :: [Tag String]
tags   = forall str. StringLike str => str -> [Tag str]
parseTags String
results
          anchor :: [Tag String]
anchor = forall a. Int -> [a] -> [a]
take Int
1
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall str t. (StringLike str, TagRep t) => Tag str -> t -> Bool
~/= (String
"<a>" :: String))
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall str t. (StringLike str, TagRep t) => Tag str -> t -> Bool
~/= (String
"<h3 class='r'>" :: String))
            forall a b. (a -> b) -> a -> b
$ [Tag String]
tags
          url :: Text
url = case [Tag String]
anchor of
            [t :: Tag String
t@(TagOpen{})] -> String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/=Char
'&') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
/=Char
'h') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall str.
(Show str, Eq str, StringLike str) =>
str -> Tag str -> str
fromAttrib String
"href" forall a b. (a -> b) -> a -> b
$ Tag String
t
            [Tag String]
_ -> Text
searchTerm
      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 :: String -> IO String
openURL String
x = forall ty. Result (Response ty) -> IO ty
getResponseBody forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall ty. HStream ty => Request ty -> IO (Result (Response ty))
simpleHTTP (String -> Request_String
getRequest String
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
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 =
      (forall a. a -> Maybe a -> a
fromMaybe Text
target forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
T.pack) 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 forall s a. s -> Getting a s a -> a
^. Lens' BlogLiterately (Maybe String)
blog) of
          (Bool
_    , Maybe String
Nothing ) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
          (Bool
True , Just String
url) -> String -> String -> String -> String -> IO (Maybe String)
getPostURL String
url (Text -> String
T.unpack Text
target) (BlogLiterately -> String
user' BlogLiterately
bl) (BlogLiterately -> String
password' BlogLiterately
bl)
          (Bool
False, Just String
url) -> Int -> String -> String -> String -> String -> IO (Maybe String)
findTitle Int
20 String
url (Text -> String
T.unpack Text
target) (BlogLiterately -> String
user' BlogLiterately
bl) (BlogLiterately -> String
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 = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack forall a b. (a -> b) -> a -> b
$
      case forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"/" (Text -> String
T.unpack Text
target) of
        (String
user : String
repo : [String]
ghTarget) -> String
github String -> String -> String
</> String
user String -> String -> String
</> String
repo String -> String -> String
</> [String] -> String
mkTarget [String]
ghTarget
        [String]
_ -> String
github String -> String -> String
</> (Text -> String
T.unpack Text
target)
    github :: String
github = String
"https://github.com/"
    mkTarget :: [String] -> String
mkTarget []                 = String
""
    mkTarget ((Char
'@': String
hash) : [String]
_)  = String
"commit" String -> String -> String
</> String
hash
    mkTarget ((Char
'#': String
issue) : [String]
_) = String
"issues" String -> String -> String
</> String
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 = forall (m :: * -> *) a. Monad m => a -> m a
return 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 (forall a b. a -> b -> a
const Bool
True)
  where
    extractTitle :: StateT (BlogLiterately, Pandoc) PandocIO ()
extractTitle = do
      (Pandoc (Meta Map Text MetaValue
m) [Block]
_) <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a, b) -> b
snd
      case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
"title" Map Text MetaValue
m of
        Just (MetaString Text
s) ->
          forall {s} {m :: * -> *}.
(MonadState s m, Field1 s s BlogLiterately BlogLiterately) =>
String -> m ()
setTitle (Text -> String
T.unpack Text
s)
        Just (MetaInlines [Inline]
is) ->
          forall {s} {m :: * -> *}.
(MonadState s m, Field1 s s BlogLiterately BlogLiterately) =>
String -> m ()
setTitle (forall a. [a] -> [[a]] -> [a]
intercalate String
" " [Text -> String
T.unpack Text
s | Str Text
s <- [Inline]
is])
        Maybe MetaValue
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- title set explicitly with --title takes precedence.
    setTitle :: String -> m ()
setTitle String
s = forall s t a b. Field1 s t a b => Lens s t a b
_1forall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' BlogLiterately (Maybe String)
title forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` forall a. a -> Maybe a
Just String
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' (forall a b. a -> b -> a
const Bool
True)
  where
    optionsXF' :: StateT (BlogLiterately, Pandoc) PandocIO ()
optionsXF' = do
      ([ParseError]
errs, BlogLiterately
opts) <- forall a b c. (Data a, Monoid b, Data c) => (a -> b) -> c -> b
queryWith Block -> ([ParseError], BlogLiterately)
extractOptions forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a, b) -> b
snd
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> IO ()
print) [ParseError]
errs
      forall s t a b. Field1 s t a b => Lens s t a b
_1 forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (forall a. Semigroup a => a -> a -> a
<> BlogLiterately
opts)
      forall s t a b. Field2 s t a b => Lens s t a b
_2 forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= forall a b. (Data a, Data b) => (a -> a) -> b -> b
bottomUp (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap 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 = forall a. Text -> (Attr -> Text -> a) -> (Block -> a) -> Block -> a
onTag Text
"blopts" (forall a b. a -> b -> a
const (String -> ([ParseError], BlogLiterately)
readBLOptions forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack)) (forall a b. a -> b -> a
const forall a. Monoid a => a
mempty)

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

-- | 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 forall s a. s -> Getting a s a -> a
^. Lens' BlogLiterately (Maybe String)
blog)     forall a b. a -> (a -> b) -> b
& forall s a. Getting Any s a -> s -> Bool
has   forall a b. Prism (Maybe a) (Maybe b) a b
_Just)
                   Bool -> Bool -> Bool
&& ((BlogLiterately
bl forall s a. s -> Getting a s a -> a
^. Lens' BlogLiterately (Maybe String)
password) forall a b. a -> (a -> b) -> b
& forall s t a b. APrism s t a b -> s -> Bool
isn't forall a b. Prism (Maybe a) (Maybe b) a b
_Just)
    passwordPrompt :: StateT (BlogLiterately, Pandoc) PandocIO ()
passwordPrompt  = do
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
"Password: " forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout
      String
pwd <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getLine
      forall s t a b. Field1 s t a b => Lens s t a b
_1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' BlogLiterately (Maybe String)
password forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= forall a. a -> Maybe a
Just String
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 (forall a b. a -> b -> a
const Bool
True)
  where
    doHighlightOptsXF :: StateT (BlogLiterately, Pandoc) PandocIO ()
doHighlightOptsXF = do
      StylePrefs
prefs <- (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String -> IO StylePrefs
getStylePrefs) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (forall s t a b. Field1 s t a b => Lens s t a b
_1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' BlogLiterately (Maybe String)
style)
      (forall s t a b. Field1 s t a b => Lens s t a b
_1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' BlogLiterately (Maybe HsHighlight)
hsHighlight) forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe (StylePrefs -> HsHighlight
HsColourInline StylePrefs
prefs)
                                         (Prism' HsHighlight StylePrefs
_HsColourInline 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 (forall a b. a -> b -> a
const 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 (forall a b. a -> b -> a
const Bool
True)
  where
    doProfileXF :: StateT (BlogLiterately, Pandoc) PandocIO ()
doProfileXF = do
      BlogLiterately
bl  <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall s t a b. Field1 s t a b => Lens s t a b
_1
      BlogLiterately
bl' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ BlogLiterately -> IO BlogLiterately
loadProfile BlogLiterately
bl
      forall s t a b. Field1 s t a b => Lens s t a b
_1 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
blforall s a. s -> Getting a s a -> a
^.Lens' BlogLiterately (Maybe String)
profile of
    Maybe String
Nothing          -> forall (m :: * -> *) a. Monad m => a -> m a
return BlogLiterately
bl
    Just String
profileName -> do
      String
appDir <- String -> IO String
getAppUserDataDirectory String
"BlogLiterately"

      let profileCfg :: String
profileCfg = String
appDir String -> String -> String
</> String
profileName String -> String -> String
<.> String
"cfg"
      Bool
e <- String -> IO Bool
doesFileExist String
profileCfg
      case Bool
e of
        Bool
False -> do
          String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
profileCfg forall a. [a] -> [a] -> [a]
++ String
": file not found"
          forall a. IO a
exitFailure
        Bool
True  -> do
          ([ParseError]
errs, BlogLiterately
blProfile) <- String -> ([ParseError], BlogLiterately)
readBLOptions forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile String
profileCfg
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a. Show a => a -> IO ()
print [ParseError]
errs
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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]
-> String
-> IO (Either PandocError (BlogLiterately, String))
xformDoc BlogLiterately
bl [Transform]
xforms String
s = do
  Right Template Text
tpl <- forall (m :: * -> *) a.
(TemplateMonad m, TemplateTarget a) =>
String -> Text -> m (Either String (Template a))
compileTemplate String
"" Text
blHtmlTemplate
  forall a. PandocIO a -> IO (Either PandocError a)
runIO forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (     String -> String
fixLineEndings
      forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> String -> Text
T.pack
      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
      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
      forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (\(BlogLiterately
bl', Pandoc
p) -> (BlogLiterately
bl',) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeHtml5String (BlogLiterately -> Template Text -> WriterOptions
writeOpts BlogLiterately
bl' Template Text
tpl) Pandoc
p)
      forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall s t a b. Field2 s t a b => Lens s t a b
_2 (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack)
    )
    forall a b. (a -> b) -> a -> b
$ String
s
  where
    parseFile :: ReaderOptions -> Text -> PandocIO Pandoc
    parseFile :: ReaderOptions -> Text -> PandocIO Pandoc
parseFile ReaderOptions
opts =
      case BlogLiterately
blforall s a. s -> Getting a s a -> a
^.Lens' BlogLiterately (Maybe String)
format of
        Just String
"rst"      -> forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readRST      ReaderOptions
opts
        Just String
_          -> forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readMarkdown ReaderOptions
opts
        Maybe String
Nothing         ->
          case String -> String
takeExtension (BlogLiterately -> String
file' BlogLiterately
bl) of
            String
".rst"  -> forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readRST ReaderOptions
opts
            String
".rest" -> forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readRST ReaderOptions
opts
            String
".txt"  -> forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readRST ReaderOptions
opts
            String
_       -> forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readMarkdown ReaderOptions
opts

    parseOpts :: ReaderOptions
parseOpts = forall a. Default a => a
def
      { readerExtensions :: Extensions
readerExtensions = Extensions
pandocExtensions forall a b. a -> (a -> b) -> b
&
          forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id
            [ Extension -> Extensions -> Extensions
enableExtension Extension
Ext_tex_math_single_backslash
            , case BlogLiterately
blforall s a. s -> Getting a s a -> a
^.Lens' BlogLiterately (Maybe Bool)
litHaskell of
                Just Bool
False -> 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 = forall a. Default a => a
def
      { writerReferenceLinks :: Bool
writerReferenceLinks  = Bool
True
      , writerWrapText :: WrapOption
writerWrapText        = WrapOption
WrapNone
      , writerTableOfContents :: Bool
writerTableOfContents = BlogLiterately -> Bool
toc' BlogLiterately
bl
      , writerHTMLMathMethod :: HTMLMathMethod
writerHTMLMathMethod  =
          case BlogLiterately -> String
math' BlogLiterately
bl of
            String
""  -> HTMLMathMethod
PlainMath
            String
opt -> Text -> HTMLMathMethod
mathOption (String -> Text
T.pack String
opt)
      , writerTemplate :: Maybe (Template Text)
writerTemplate        = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.dropWhile (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 :: String -> String
fixLineEndings []             = []
fixLineEndings (Char
'\r':Char
'\n':String
cs) = Char
'\n'forall a. a -> [a] -> [a]
:String -> String
fixLineEndings String
cs
fixLineEndings (Char
c:String
cs)         = Char
cforall a. a -> [a] -> [a]
:String -> String
fixLineEndings String
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$"
  ]