{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Text.BlogLiterately.Transform
(
standardTransforms
, optionsXF
, profileXF
, highlightOptsXF
, passwordXF
, titleXF
, rawtexifyXF
, wptexifyXF
, ghciXF
, uploadImagesXF
, highlightXF
, centerImagesXF
, citationsXF
, specialLinksXF
, mkSpecialLinksXF
, standardSpecialLinks
, luckyLink
, wikiLink
, postLink
, Transform(..), pureTransform, ioTransform, pioTransform, runTransform, runTransforms
, xformDoc
, 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)
data Transform = Transform
{ Transform -> StateT (BlogLiterately, Pandoc) PandocIO ()
getTransform :: StateT (BlogLiterately, Pandoc) PandocIO ()
, Transform -> BlogLiterately -> Bool
xfCond :: BlogLiterately -> Bool
}
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)
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))
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')
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
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)
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'
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'
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'
uploadImagesXF :: Transform
uploadImagesXF :: Transform
uploadImagesXF = (BlogLiterately -> Pandoc -> IO Pandoc)
-> (BlogLiterately -> Bool) -> Transform
ioTransform BlogLiterately -> Pandoc -> IO Pandoc
uploadAllImages BlogLiterately -> Bool
uploadImages'
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)
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
specialLinksXF :: Transform
specialLinksXF :: Transform
specialLinksXF = [SpecialLink] -> Transform
mkSpecialLinksXF [SpecialLink]
standardSpecialLinks
standardSpecialLinks :: [SpecialLink]
standardSpecialLinks :: [SpecialLink]
standardSpecialLinks =
[ SpecialLink
luckyLink
, SpecialLink
wikiLink
, SpecialLink
postLink
, SpecialLink
githubLink
, SpecialLink
hackageLink
]
type SpecialLink = (Text, Text -> BlogLiterately -> IO Text)
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)
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
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
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)
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 :: 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)
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
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/"
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 ()
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)
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
extractOptions :: Block -> ([ParseError], BlogLiterately)
= 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)
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
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
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)
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'
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'
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
standardTransforms :: [Transform]
standardTransforms :: [Transform]
standardTransforms =
[
Transform
optionsXF
, Transform
profileXF
, Transform
passwordXF
, Transform
titleXF
, Transform
rawtexifyXF
, Transform
wptexifyXF
, Transform
ghciXF
, Transform
uploadImagesXF
, Transform
centerImagesXF
, Transform
specialLinksXF
, Transform
highlightOptsXF
, Transform
highlightXF
, Transform
citationsXF
]
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
]
}
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
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
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$"
]