{-# 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, 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 (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)
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))
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')
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
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)
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'
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'
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'
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))
(forall a b. a -> b -> a
const Bool
True)
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
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) (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 = 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
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
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)
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 :: 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)
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
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/"
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 ()
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)
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)
extractOptions :: Block -> ([ParseError], BlogLiterately)
= 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)
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]
:[])
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
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)
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'
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'
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
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]
-> 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
]
}
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
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
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$"
]