{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Text.Pandoc.Writers.Muse (writeMuse) where
import Control.Monad (zipWithM)
import Control.Monad.Except (throwError)
import Control.Monad.Reader
( asks, MonadReader(local), ReaderT(runReaderT) )
import Control.Monad.State.Strict
( StateT, gets, modify, evalStateT )
import Data.Char (isAlphaNum, isAsciiLower, isAsciiUpper, isDigit, isSpace)
import Data.Default
import Data.List (intersperse, transpose)
import Data.List.NonEmpty (nonEmpty, NonEmpty(..))
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Text (Text)
import System.FilePath (takeExtension)
import Text.Pandoc.Class.PandocMonad (PandocMonad)
import Text.Pandoc.Definition
import Text.Pandoc.Error
import Text.Pandoc.ImageSize
import Text.Pandoc.Options
import Text.DocLayout
import Text.Pandoc.Shared
import Text.Pandoc.URI
import Text.Pandoc.Templates (renderTemplate)
import Text.Pandoc.Writers.Math
import Text.Pandoc.Writers.Shared
type Notes = [[Block]]
type Muse m = ReaderT WriterEnv (StateT WriterState m)
data WriterEnv =
WriterEnv { WriterEnv -> WriterOptions
envOptions :: WriterOptions
, WriterEnv -> Bool
envTopLevel :: Bool
, WriterEnv -> Bool
envInsideBlock :: Bool
, WriterEnv -> Bool
envInlineStart :: Bool
, WriterEnv -> Bool
envInsideLinkDescription :: Bool
, WriterEnv -> Bool
envAfterSpace :: Bool
, WriterEnv -> Bool
envOneLine :: Bool
, WriterEnv -> Bool
envInsideAsterisks :: Bool
, WriterEnv -> Bool
envNearAsterisks :: Bool
}
data WriterState =
WriterState { WriterState -> Notes
stNotes :: Notes
, WriterState -> Int
stNoteNum :: Int
, WriterState -> Set Text
stIds :: Set.Set Text
, WriterState -> Bool
stUseTags :: Bool
}
instance Default WriterState
where def :: WriterState
def = WriterState { stNotes :: Notes
stNotes = []
, stNoteNum :: Int
stNoteNum = Int
1
, stIds :: Set Text
stIds = Set Text
forall a. Set a
Set.empty
, stUseTags :: Bool
stUseTags = Bool
False
}
evalMuse :: PandocMonad m => Muse m a -> WriterEnv -> WriterState -> m a
evalMuse :: forall (m :: * -> *) a.
PandocMonad m =>
Muse m a -> WriterEnv -> WriterState -> m a
evalMuse Muse m a
document WriterEnv
env = StateT WriterState m a -> WriterState -> m a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (StateT WriterState m a -> WriterState -> m a)
-> StateT WriterState m a -> WriterState -> m a
forall a b. (a -> b) -> a -> b
$ Muse m a -> WriterEnv -> StateT WriterState m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Muse m a
document WriterEnv
env
writeMuse :: PandocMonad m
=> WriterOptions
-> Pandoc
-> m Text
writeMuse :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeMuse WriterOptions
opts Pandoc
document =
Muse m Text -> WriterEnv -> WriterState -> m Text
forall (m :: * -> *) a.
PandocMonad m =>
Muse m a -> WriterEnv -> WriterState -> m a
evalMuse (Pandoc -> Muse m Text
forall (m :: * -> *). PandocMonad m => Pandoc -> Muse m Text
pandocToMuse Pandoc
document) WriterEnv
env WriterState
forall a. Default a => a
def
where env :: WriterEnv
env = WriterEnv { envOptions :: WriterOptions
envOptions = WriterOptions
opts
, envTopLevel :: Bool
envTopLevel = Bool
True
, envInsideBlock :: Bool
envInsideBlock = Bool
False
, envInlineStart :: Bool
envInlineStart = Bool
True
, envInsideLinkDescription :: Bool
envInsideLinkDescription = Bool
False
, envAfterSpace :: Bool
envAfterSpace = Bool
False
, envOneLine :: Bool
envOneLine = Bool
False
, envInsideAsterisks :: Bool
envInsideAsterisks = Bool
False
, envNearAsterisks :: Bool
envNearAsterisks = Bool
False
}
pandocToMuse :: PandocMonad m
=> Pandoc
-> Muse m Text
pandocToMuse :: forall (m :: * -> *). PandocMonad m => Pandoc -> Muse m Text
pandocToMuse (Pandoc Meta
meta [Block]
blocks) = do
opts <- (WriterEnv -> WriterOptions)
-> ReaderT WriterEnv (StateT WriterState m) WriterOptions
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> WriterOptions
envOptions
let colwidth = if WriterOptions -> WrapOption
writerWrapText WriterOptions
opts WrapOption -> WrapOption -> Bool
forall a. Eq a => a -> a -> Bool
== WrapOption
WrapAuto
then Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ WriterOptions -> Int
writerColumns WriterOptions
opts
else Maybe Int
forall a. Maybe a
Nothing
metadata <- metaToContext opts
blockListToMuse
(fmap chomp . inlineListToMuse)
meta
body <- blockListToMuse blocks
notes <- currentNotesToMuse
let main = Doc Text
body Doc Text -> Doc Text -> Doc Text
forall a. Doc a -> Doc a -> Doc a
$+$ Doc Text
notes
let context = Text -> Doc Text -> Context Text -> Context Text
forall a b. ToContext a b => Text -> b -> Context a -> Context a
defField Text
"body" Doc Text
main Context Text
metadata
return $ render colwidth $
case writerTemplate opts of
Maybe (Template Text)
Nothing -> Doc Text
main
Just Template Text
tpl -> Template Text -> Context Text -> Doc Text
forall a b.
(TemplateTarget a, ToContext a b) =>
Template a -> b -> Doc a
renderTemplate Template Text
tpl Context Text
context
catWithBlankLines :: PandocMonad m
=> [Block]
-> Int
-> Muse m (Doc Text)
catWithBlankLines :: forall (m :: * -> *).
PandocMonad m =>
[Block] -> Int -> Muse m (Doc Text)
catWithBlankLines (Block
b : [Block]
bs) Int
n = do
b' <- Block -> Muse m (Doc Text)
forall (m :: * -> *). PandocMonad m => Block -> Muse m (Doc Text)
blockToMuseWithNotes Block
b
bs' <- flatBlockListToMuse bs
return $ b' <> blanklines n <> bs'
catWithBlankLines [Block]
_ Int
_ = String -> Muse m (Doc Text)
forall a. HasCallStack => String -> a
error String
"Expected at least one block"
flatBlockListToMuse :: PandocMonad m
=> [Block]
-> Muse m (Doc Text)
flatBlockListToMuse :: forall (m :: * -> *). PandocMonad m => [Block] -> Muse m (Doc Text)
flatBlockListToMuse bs :: [Block]
bs@(BulletList Notes
_ : BulletList Notes
_ : [Block]
_) = [Block] -> Int -> Muse m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
[Block] -> Int -> Muse m (Doc Text)
catWithBlankLines [Block]
bs Int
2
flatBlockListToMuse bs :: [Block]
bs@(OrderedList (Int
_, ListNumberStyle
style1, ListNumberDelim
_) Notes
_ : OrderedList (Int
_, ListNumberStyle
style2, ListNumberDelim
_) Notes
_ : [Block]
_) =
[Block] -> Int -> Muse m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
[Block] -> Int -> Muse m (Doc Text)
catWithBlankLines [Block]
bs (if ListNumberStyle
style1' ListNumberStyle -> ListNumberStyle -> Bool
forall a. Eq a => a -> a -> Bool
== ListNumberStyle
style2' then Int
2 else Int
0)
where
style1' :: ListNumberStyle
style1' = ListNumberStyle -> ListNumberStyle
normalizeStyle ListNumberStyle
style1
style2' :: ListNumberStyle
style2' = ListNumberStyle -> ListNumberStyle
normalizeStyle ListNumberStyle
style2
normalizeStyle :: ListNumberStyle -> ListNumberStyle
normalizeStyle ListNumberStyle
DefaultStyle = ListNumberStyle
Decimal
normalizeStyle ListNumberStyle
s = ListNumberStyle
s
flatBlockListToMuse bs :: [Block]
bs@(DefinitionList [([Inline], Notes)]
_ : DefinitionList [([Inline], Notes)]
_ : [Block]
_) = [Block] -> Int -> Muse m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
[Block] -> Int -> Muse m (Doc Text)
catWithBlankLines [Block]
bs Int
2
flatBlockListToMuse bs :: [Block]
bs@(Block
_ : [Block]
_) = [Block] -> Int -> Muse m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
[Block] -> Int -> Muse m (Doc Text)
catWithBlankLines [Block]
bs Int
0
flatBlockListToMuse [] = Doc Text -> Muse m (Doc Text)
forall a. a -> ReaderT WriterEnv (StateT WriterState m) a
forall (m :: * -> *) a. Monad m => a -> m a
return Doc Text
forall a. Monoid a => a
mempty
simpleTable :: PandocMonad m
=> [Inline]
-> [[Block]]
-> [[[Block]]]
-> Muse m (Doc Text)
simpleTable :: forall (m :: * -> *).
PandocMonad m =>
[Inline] -> Notes -> [Notes] -> Muse m (Doc Text)
simpleTable [Inline]
caption Notes
headers [Notes]
rows = do
topLevel <- (WriterEnv -> Bool)
-> ReaderT WriterEnv (StateT WriterState m) Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Bool
envTopLevel
caption' <- inlineListToMuse caption
headers' <- mapM blockListToMuse headers
rows' <- mapM (mapM blockListToMuse) rows
let widthsInChars = Int -> (NonEmpty Int -> Int) -> Maybe (NonEmpty Int) -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 NonEmpty Int -> Int
forall a. Ord a => NonEmpty a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Maybe (NonEmpty Int) -> Int)
-> ([Doc Text] -> Maybe (NonEmpty Int)) -> [Doc Text] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Maybe (NonEmpty Int)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([Int] -> Maybe (NonEmpty Int))
-> ([Doc Text] -> [Int]) -> [Doc Text] -> Maybe (NonEmpty Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Doc Text -> Int) -> [Doc Text] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Doc Text -> Int
forall a. (IsString a, HasChars a) => Doc a -> Int
offset ([Doc Text] -> Int) -> [[Doc Text]] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
[[Doc Text]] -> [[Doc Text]]
forall a. [[a]] -> [[a]]
transpose ([Doc Text]
headers' [Doc Text] -> [[Doc Text]] -> [[Doc Text]]
forall a. a -> [a] -> [a]
: [[Doc Text]]
rows')
let hpipeBlocks Text
sep [Doc Text]
blocks = [Doc Text] -> Doc Text
forall a. [Doc a] -> Doc a
hcat ([Doc Text] -> Doc Text) -> [Doc Text] -> Doc Text
forall a b. (a -> b) -> a -> b
$ Doc Text -> [Doc Text] -> [Doc Text]
forall a. a -> [a] -> [a]
intersperse Doc Text
sep' [Doc Text]
blocks
where sep' :: Doc Text
sep' = Int -> Doc Text -> Doc Text
forall a. HasChars a => Int -> Doc a -> Doc a
lblock (Text -> Int
T.length Text
sep) (Doc Text -> Doc Text) -> Doc Text -> Doc Text
forall a b. (a -> b) -> a -> b
$ Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal Text
sep
let makeRow Text
sep = Text -> [Doc Text] -> Doc Text
hpipeBlocks Text
sep ([Doc Text] -> Doc Text)
-> ([Doc Text] -> [Doc Text]) -> [Doc Text] -> Doc Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Doc Text -> Doc Text) -> [Int] -> [Doc Text] -> [Doc Text]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Doc Text -> Doc Text
forall a. HasChars a => Int -> Doc a -> Doc a
lblock [Int]
widthsInChars
let head' = Text -> [Doc Text] -> Doc Text
makeRow Text
" || " [Doc Text]
headers'
rows'' <- mapM (\Notes
row -> Text -> [Doc Text] -> Doc Text
makeRow Text
rowSeparator ([Doc Text] -> Doc Text)
-> ReaderT WriterEnv (StateT WriterState m) [Doc Text]
-> Muse m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Block] -> Muse m (Doc Text))
-> Notes -> ReaderT WriterEnv (StateT WriterState m) [Doc Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM [Block] -> Muse m (Doc Text)
forall (m :: * -> *). PandocMonad m => [Block] -> Muse m (Doc Text)
blockListToMuse Notes
row) rows
let body = [Doc Text] -> Doc Text
forall a. [Doc a] -> Doc a
vcat [Doc Text]
rows''
return $ (if topLevel then nest 1 else id) ((if noHeaders then empty else head')
$$ body
$$ (if null caption then empty else "|+ " <> caption' <> " +|"))
$$ blankline
where noHeaders :: Bool
noHeaders = ([Block] -> Bool) -> Notes -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all [Block] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Notes
headers
rowSeparator :: Text
rowSeparator = if Bool
noHeaders then Text
" | " else Text
" | "
blockListToMuse :: PandocMonad m
=> [Block]
-> Muse m (Doc Text)
blockListToMuse :: forall (m :: * -> *). PandocMonad m => [Block] -> Muse m (Doc Text)
blockListToMuse =
(WriterEnv -> WriterEnv)
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall a.
(WriterEnv -> WriterEnv)
-> ReaderT WriterEnv (StateT WriterState m) a
-> ReaderT WriterEnv (StateT WriterState m) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\WriterEnv
env -> WriterEnv
env { envTopLevel = not (envInsideBlock env)
, envInsideBlock = True
}) (ReaderT WriterEnv (StateT WriterState m) (Doc Text)
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text))
-> ([Block] -> ReaderT WriterEnv (StateT WriterState m) (Doc Text))
-> [Block]
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Block] -> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall (m :: * -> *). PandocMonad m => [Block] -> Muse m (Doc Text)
flatBlockListToMuse
blockToMuse :: PandocMonad m
=> Block
-> Muse m (Doc Text)
blockToMuse :: forall (m :: * -> *). PandocMonad m => Block -> Muse m (Doc Text)
blockToMuse (Plain [Inline]
inlines) = [Inline] -> Muse m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
[Inline] -> Muse m (Doc Text)
inlineListToMuse' [Inline]
inlines
blockToMuse (Para [Inline]
inlines) = do
contents <- [Inline] -> Muse m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
[Inline] -> Muse m (Doc Text)
inlineListToMuse' [Inline]
inlines
return $ contents <> blankline
blockToMuse (LineBlock [[Inline]]
lns) = do
lns' <- (WriterEnv -> WriterEnv)
-> ReaderT WriterEnv (StateT WriterState m) [Doc Text]
-> ReaderT WriterEnv (StateT WriterState m) [Doc Text]
forall a.
(WriterEnv -> WriterEnv)
-> ReaderT WriterEnv (StateT WriterState m) a
-> ReaderT WriterEnv (StateT WriterState m) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\WriterEnv
env -> WriterEnv
env { envOneLine = True }) (ReaderT WriterEnv (StateT WriterState m) [Doc Text]
-> ReaderT WriterEnv (StateT WriterState m) [Doc Text])
-> ReaderT WriterEnv (StateT WriterState m) [Doc Text]
-> ReaderT WriterEnv (StateT WriterState m) [Doc Text]
forall a b. (a -> b) -> a -> b
$ ([Inline] -> Muse m (Doc Text))
-> [[Inline]]
-> ReaderT WriterEnv (StateT WriterState m) [Doc Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM [Inline] -> Muse m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
[Inline] -> Muse m (Doc Text)
inlineListToMuse [[Inline]]
lns
return $ nowrap $ vcat (map (literal "> " <>) lns') <> blankline
blockToMuse (CodeBlock (Text
_,[Text]
_,[(Text, Text)]
_) Text
str) =
Doc Text -> Muse m (Doc Text)
forall a. a -> ReaderT WriterEnv (StateT WriterState m) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> Muse m (Doc Text)) -> Doc Text -> Muse m (Doc Text)
forall a b. (a -> b) -> a -> b
$ Doc Text
"<example>" Doc Text -> Doc Text -> Doc Text
forall a. Doc a -> Doc a -> Doc a
$$ Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal Text
str Doc Text -> Doc Text -> Doc Text
forall a. Doc a -> Doc a -> Doc a
$$ Doc Text
"</example>" Doc Text -> Doc Text -> Doc Text
forall a. Doc a -> Doc a -> Doc a
$$ Doc Text
forall a. Doc a
blankline
blockToMuse (RawBlock (Format Text
format) Text
str) =
Doc Text -> Muse m (Doc Text)
forall a. a -> ReaderT WriterEnv (StateT WriterState m) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> Muse m (Doc Text)) -> Doc Text -> Muse m (Doc Text)
forall a b. (a -> b) -> a -> b
$ Doc Text
forall a. Doc a
blankline Doc Text -> Doc Text -> Doc Text
forall a. Doc a -> Doc a -> Doc a
$$ Doc Text
"<literal style=\"" Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal Text
format Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
"\">" Doc Text -> Doc Text -> Doc Text
forall a. Doc a -> Doc a -> Doc a
$$
Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal Text
str Doc Text -> Doc Text -> Doc Text
forall a. Doc a -> Doc a -> Doc a
$$ Doc Text
"</literal>" Doc Text -> Doc Text -> Doc Text
forall a. Doc a -> Doc a -> Doc a
$$ Doc Text
forall a. Doc a
blankline
blockToMuse (BlockQuote [Block]
blocks) = do
contents <- [Block] -> Muse m (Doc Text)
forall (m :: * -> *). PandocMonad m => [Block] -> Muse m (Doc Text)
flatBlockListToMuse [Block]
blocks
return $ blankline
<> "<quote>"
$$ nest 0 contents
$$ "</quote>"
<> blankline
blockToMuse (OrderedList (Int
start, ListNumberStyle
style, ListNumberDelim
_) Notes
items) = do
let markers :: [Text]
markers = Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
take (Notes -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Notes
items) ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Int, ListNumberStyle, ListNumberDelim) -> [Text]
orderedListMarkers
(Int
start, ListNumberStyle
style, ListNumberDelim
Period)
contents <- (Text -> [Block] -> Muse m (Doc Text))
-> [Text]
-> Notes
-> ReaderT WriterEnv (StateT WriterState m) [Doc Text]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Text -> [Block] -> Muse m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
Text -> [Block] -> Muse m (Doc Text)
orderedListItemToMuse [Text]
markers Notes
items
topLevel <- asks envTopLevel
return $ (if topLevel then nest 1 else id) (vcat contents) $$ blankline
where orderedListItemToMuse :: PandocMonad m
=> Text
-> [Block]
-> Muse m (Doc Text)
orderedListItemToMuse :: forall (m :: * -> *).
PandocMonad m =>
Text -> [Block] -> Muse m (Doc Text)
orderedListItemToMuse Text
marker [Block]
item = Int -> Doc Text -> Doc Text -> Doc Text
forall a. IsString a => Int -> Doc a -> Doc a -> Doc a
hang (Text -> Int
T.length Text
marker Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal Text
marker Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
forall a. Doc a
space)
(Doc Text -> Doc Text)
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Block] -> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall (m :: * -> *). PandocMonad m => [Block] -> Muse m (Doc Text)
blockListToMuse [Block]
item
blockToMuse (BulletList Notes
items) = do
contents <- ([Block] -> Muse m (Doc Text))
-> Notes -> ReaderT WriterEnv (StateT WriterState m) [Doc Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM [Block] -> Muse m (Doc Text)
forall (m :: * -> *). PandocMonad m => [Block] -> Muse m (Doc Text)
bulletListItemToMuse Notes
items
topLevel <- asks envTopLevel
return $ (if topLevel then nest 1 else id) (vcat contents) $$ blankline
where bulletListItemToMuse :: PandocMonad m
=> [Block]
-> Muse m (Doc Text)
bulletListItemToMuse :: forall (m :: * -> *). PandocMonad m => [Block] -> Muse m (Doc Text)
bulletListItemToMuse [Block]
item = do
(WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ())
-> (WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall a b. (a -> b) -> a -> b
$ \WriterState
st -> WriterState
st { stUseTags = False }
Int -> Doc Text -> Doc Text -> Doc Text
forall a. IsString a => Int -> Doc a -> Doc a -> Doc a
hang Int
2 Doc Text
"- " (Doc Text -> Doc Text)
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Block] -> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall (m :: * -> *). PandocMonad m => [Block] -> Muse m (Doc Text)
blockListToMuse [Block]
item
blockToMuse (DefinitionList [([Inline], Notes)]
items) = do
contents <- (([Inline], Notes) -> Muse m (Doc Text))
-> [([Inline], Notes)]
-> ReaderT WriterEnv (StateT WriterState m) [Doc Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([Inline], Notes) -> Muse m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
([Inline], Notes) -> Muse m (Doc Text)
definitionListItemToMuse [([Inline], Notes)]
items
topLevel <- asks envTopLevel
return $ (if topLevel then nest 1 else id) (vcat contents) $$ blankline
where definitionListItemToMuse :: PandocMonad m
=> ([Inline], [[Block]])
-> Muse m (Doc Text)
definitionListItemToMuse :: forall (m :: * -> *).
PandocMonad m =>
([Inline], Notes) -> Muse m (Doc Text)
definitionListItemToMuse ([Inline]
label, Notes
defs) = do
(WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ())
-> (WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall a b. (a -> b) -> a -> b
$ \WriterState
st -> WriterState
st { stUseTags = False }
label' <- (WriterEnv -> WriterEnv)
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall a.
(WriterEnv -> WriterEnv)
-> ReaderT WriterEnv (StateT WriterState m) a
-> ReaderT WriterEnv (StateT WriterState m) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\WriterEnv
env -> WriterEnv
env { envOneLine = True, envAfterSpace = True }) (ReaderT WriterEnv (StateT WriterState m) (Doc Text)
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text))
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall a b. (a -> b) -> a -> b
$ [Inline] -> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
[Inline] -> Muse m (Doc Text)
inlineListToMuse' [Inline]
label
let ind = Doc Text -> Int
offset' Doc Text
label'
hang ind (nowrap label') . vcat <$> mapM descriptionToMuse defs
where offset' :: Doc Text -> Int
offset' Doc Text
d = NonEmpty Int -> Int
forall a. Ord a => NonEmpty a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Int
0 Int -> [Int] -> NonEmpty Int
forall a. a -> [a] -> NonEmpty a
:| (Text -> Int) -> [Text] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Int
T.length
(Text -> [Text]
T.lines (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Maybe Int -> Doc Text -> Text
forall a. HasChars a => Maybe Int -> Doc a -> a
render Maybe Int
forall a. Maybe a
Nothing Doc Text
d))
descriptionToMuse :: PandocMonad m
=> [Block]
-> Muse m (Doc Text)
descriptionToMuse :: forall (m :: * -> *). PandocMonad m => [Block] -> Muse m (Doc Text)
descriptionToMuse [Block]
desc = Int -> Doc Text -> Doc Text -> Doc Text
forall a. IsString a => Int -> Doc a -> Doc a -> Doc a
hang Int
4 Doc Text
" :: " (Doc Text -> Doc Text)
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Block] -> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall (m :: * -> *). PandocMonad m => [Block] -> Muse m (Doc Text)
blockListToMuse [Block]
desc
blockToMuse (Header Int
level (Text
ident,[Text]
_,[(Text, Text)]
_) [Inline]
inlines) = do
opts <- (WriterEnv -> WriterOptions)
-> ReaderT WriterEnv (StateT WriterState m) WriterOptions
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> WriterOptions
envOptions
topLevel <- asks envTopLevel
contents <- local (\WriterEnv
env -> WriterEnv
env { envOneLine = True }) $ inlineListToMuse' inlines
ids <- gets stIds
let autoId = Extensions -> [Inline] -> Set Text -> Text
uniqueIdent (WriterOptions -> Extensions
writerExtensions WriterOptions
opts) [Inline]
inlines Set Text
ids
modify $ \WriterState
st -> WriterState
st{ stIds = Set.insert autoId ids }
let attr' = if Text -> Bool
T.null Text
ident Bool -> Bool -> Bool
|| (Extension -> WriterOptions -> Bool
forall a. HasSyntaxExtensions a => Extension -> a -> Bool
isEnabled Extension
Ext_auto_identifiers WriterOptions
opts Bool -> Bool -> Bool
&& Text
ident Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
autoId)
then Doc Text
forall a. Doc a
empty
else Doc Text
"#" Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal Text
ident Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
forall a. Doc a
cr
let header' = if Bool
topLevel then Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal (Int -> Text -> Text
T.replicate Int
level Text
"*") Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
forall a. Doc a
space else Doc Text
forall a. Monoid a => a
mempty
return $ blankline <> attr' $$ nowrap (header' <> contents) <> blankline
blockToMuse Block
HorizontalRule = Doc Text -> Muse m (Doc Text)
forall a. a -> ReaderT WriterEnv (StateT WriterState m) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> Muse m (Doc Text)) -> Doc Text -> Muse m (Doc Text)
forall a b. (a -> b) -> a -> b
$ Doc Text
forall a. Doc a
blankline Doc Text -> Doc Text -> Doc Text
forall a. Doc a -> Doc a -> Doc a
$$ Doc Text
"----" Doc Text -> Doc Text -> Doc Text
forall a. Doc a -> Doc a -> Doc a
$$ Doc Text
forall a. Doc a
blankline
blockToMuse (Table (Text, [Text], [(Text, Text)])
_ Caption
blkCapt [ColSpec]
specs TableHead
thead [TableBody]
tbody TableFoot
tfoot) =
if Bool
isSimple Bool -> Bool -> Bool
&& Int
numcols Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
then [Inline] -> Notes -> [Notes] -> Muse m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
[Inline] -> Notes -> [Notes] -> Muse m (Doc Text)
simpleTable [Inline]
caption Notes
headers [Notes]
rows
else do
opts <- (WriterEnv -> WriterOptions)
-> ReaderT WriterEnv (StateT WriterState m) WriterOptions
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> WriterOptions
envOptions
gridTable opts blocksToDoc True (map (const AlignDefault) aligns) widths headers rows
where
([Inline]
caption, [Alignment]
aligns, [Double]
widths, Notes
headers, [Notes]
rows) = Caption
-> [ColSpec]
-> TableHead
-> [TableBody]
-> TableFoot
-> ([Inline], [Alignment], [Double], Notes, [Notes])
toLegacyTable Caption
blkCapt [ColSpec]
specs TableHead
thead [TableBody]
tbody TableFoot
tfoot
blocksToDoc :: WriterOptions
-> [Block] -> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
blocksToDoc WriterOptions
opts [Block]
blocks =
(WriterEnv -> WriterEnv)
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall a.
(WriterEnv -> WriterEnv)
-> ReaderT WriterEnv (StateT WriterState m) a
-> ReaderT WriterEnv (StateT WriterState m) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\WriterEnv
env -> WriterEnv
env { envOptions = opts }) (ReaderT WriterEnv (StateT WriterState m) (Doc Text)
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text))
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall a b. (a -> b) -> a -> b
$ [Block] -> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall (m :: * -> *). PandocMonad m => [Block] -> Muse m (Doc Text)
blockListToMuse [Block]
blocks
numcols :: Int
numcols = NonEmpty Int -> Int
forall a. Ord a => NonEmpty a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum
([Alignment] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Alignment]
aligns Int -> [Int] -> NonEmpty Int
forall a. a -> [a] -> NonEmpty a
:| [Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
widths Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: (Notes -> Int) -> [Notes] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Notes -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Notes
headersNotes -> [Notes] -> [Notes]
forall a. a -> [a] -> [a]
:[Notes]
rows))
isSimple :: Bool
isSimple = [Notes] -> Bool
onlySimpleTableCells (Notes
headers Notes -> [Notes] -> [Notes]
forall a. a -> [a] -> [a]
: [Notes]
rows) Bool -> Bool -> Bool
&& (Double -> Bool) -> [Double] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0) [Double]
widths
blockToMuse (Div (Text, [Text], [(Text, Text)])
_ [Block]
bs) = [Block] -> Muse m (Doc Text)
forall (m :: * -> *). PandocMonad m => [Block] -> Muse m (Doc Text)
flatBlockListToMuse [Block]
bs
blockToMuse (Figure (Text, [Text], [(Text, Text)])
attr Caption
capt [Block]
body) = do
Block -> Muse m (Doc Text)
forall (m :: * -> *). PandocMonad m => Block -> Muse m (Doc Text)
blockToMuse ((Text, [Text], [(Text, Text)]) -> Caption -> [Block] -> Block
figureDiv (Text, [Text], [(Text, Text)])
attr Caption
capt [Block]
body)
currentNotesToMuse :: PandocMonad m
=> Muse m (Doc Text)
currentNotesToMuse :: forall (m :: * -> *). PandocMonad m => Muse m (Doc Text)
currentNotesToMuse = do
notes <- Notes -> Notes
forall a. [a] -> [a]
reverse (Notes -> Notes)
-> ReaderT WriterEnv (StateT WriterState m) Notes
-> ReaderT WriterEnv (StateT WriterState m) Notes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (WriterState -> Notes)
-> ReaderT WriterEnv (StateT WriterState m) Notes
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Notes
stNotes
modify $ \WriterState
st -> WriterState
st { stNotes = mempty }
notesToMuse notes
notesToMuse :: PandocMonad m
=> Notes
-> Muse m (Doc Text)
notesToMuse :: forall (m :: * -> *). PandocMonad m => Notes -> Muse m (Doc Text)
notesToMuse Notes
notes = do
n <- (WriterState -> Int)
-> ReaderT WriterEnv (StateT WriterState m) Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Int
stNoteNum
modify $ \WriterState
st -> WriterState
st { stNoteNum = stNoteNum st + length notes }
vsep <$> zipWithM noteToMuse [n ..] notes
noteToMuse :: PandocMonad m
=> Int
-> [Block]
-> Muse m (Doc Text)
noteToMuse :: forall (m :: * -> *).
PandocMonad m =>
Int -> [Block] -> Muse m (Doc Text)
noteToMuse Int
num [Block]
note = do
res <- Int -> Doc Text -> Doc Text -> Doc Text
forall a. IsString a => Int -> Doc a -> Doc a -> Doc a
hang (Text -> Int
T.length Text
marker) (Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal Text
marker) (Doc Text -> Doc Text)
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(WriterEnv -> WriterEnv)
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall a.
(WriterEnv -> WriterEnv)
-> ReaderT WriterEnv (StateT WriterState m) a
-> ReaderT WriterEnv (StateT WriterState m) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\WriterEnv
env -> WriterEnv
env { envInsideBlock = True
, envInlineStart = True
, envAfterSpace = True
}) ([Block] -> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall (m :: * -> *). PandocMonad m => [Block] -> Muse m (Doc Text)
blockListToMuse [Block]
note)
return $ res <> blankline
where
marker :: Text
marker = Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
num Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"] "
blockToMuseWithNotes :: PandocMonad m
=> Block
-> Muse m (Doc Text)
blockToMuseWithNotes :: forall (m :: * -> *). PandocMonad m => Block -> Muse m (Doc Text)
blockToMuseWithNotes Block
blk = do
topLevel <- (WriterEnv -> Bool)
-> ReaderT WriterEnv (StateT WriterState m) Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Bool
envTopLevel
opts <- asks envOptions
let hdrToMuse hdr :: Block
hdr@Header{} = do
b <- Block -> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall (m :: * -> *). PandocMonad m => Block -> Muse m (Doc Text)
blockToMuse Block
hdr
if topLevel && writerReferenceLocation opts == EndOfSection
then do
notes <- currentNotesToMuse
return $ notes $+$ b
else
return b
hdrToMuse Block
b = Block -> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall (m :: * -> *). PandocMonad m => Block -> Muse m (Doc Text)
blockToMuse Block
b
b <- hdrToMuse blk
if topLevel && writerReferenceLocation opts == EndOfBlock
then do
notes <- currentNotesToMuse
return $ b $+$ notes <> blankline
else return b
escapeText :: Text -> Text
escapeText :: Text -> Text
escapeText Text
s =
Text
"<verbatim>" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"</verbatim>" Text
"<</verbatim><verbatim>/verbatim>" Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
Text
"</verbatim>"
replaceNewlines :: Text -> Text
replaceNewlines :: Text -> Text
replaceNewlines = (Char -> Char) -> Text -> Text
T.map ((Char -> Char) -> Text -> Text) -> (Char -> Char) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ \Char
c ->
if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' then Char
' ' else Char
c
startsWithMarker :: (Char -> Bool) -> Text -> Bool
startsWithMarker :: (Char -> Bool) -> Text -> Bool
startsWithMarker Char -> Bool
f Text
t = case Text -> Maybe (Char, Text)
T.uncons (Text -> Maybe (Char, Text)) -> Text -> Maybe (Char, Text)
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
f' Text
t of
Just (Char
'.', Text
xs) -> Text -> Bool
T.null Text
xs Bool -> Bool -> Bool
|| Char -> Bool
isSpace (HasCallStack => Text -> Char
Text -> Char
T.head Text
xs)
Maybe (Char, Text)
_ -> Bool
False
where
f' :: Char -> Bool
f' Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char -> Bool
f Char
c
containsNotes :: Char -> Char -> Text -> Bool
containsNotes :: Char -> Char -> Text -> Bool
containsNotes Char
left Char
right = String -> Bool
p (String -> Bool) -> (Text -> String) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
where p :: String -> Bool
p (Char
left':String
xs)
| Char
left' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
left = String -> Bool
q String
xs Bool -> Bool -> Bool
|| String -> Bool
p String
xs
| Bool
otherwise = String -> Bool
p String
xs
p String
"" = Bool
False
q :: String -> Bool
q (Char
x:String
xs)
| Char
x Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"123456789"::String) = String -> Bool
r String
xs Bool -> Bool -> Bool
|| String -> Bool
p String
xs
| Bool
otherwise = String -> Bool
p String
xs
q [] = Bool
False
r :: String -> Bool
r (Char
'0':String
xs) = String -> Bool
r String
xs Bool -> Bool -> Bool
|| String -> Bool
p String
xs
r String
xs = String -> Bool
s String
xs Bool -> Bool -> Bool
|| String -> Bool
q String
xs Bool -> Bool -> Bool
|| String -> Bool
p String
xs
s :: String -> Bool
s (Char
right':String
xs)
| Char
right' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
right = Bool
True
| Bool
otherwise = String -> Bool
p String
xs
s [] = Bool
False
shouldEscapeText :: PandocMonad m
=> Text
-> Muse m Bool
shouldEscapeText :: forall (m :: * -> *). PandocMonad m => Text -> Muse m Bool
shouldEscapeText Text
s = do
insideLink <- (WriterEnv -> Bool)
-> ReaderT WriterEnv (StateT WriterState m) Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Bool
envInsideLinkDescription
return $ T.null s ||
T.any (`elem` ("#*<=|" :: String)) s ||
"::" `T.isInfixOf` s ||
"~~" `T.isInfixOf` s ||
"[[" `T.isInfixOf` s ||
">>>" `T.isInfixOf` s ||
("]" `T.isInfixOf` s && insideLink) ||
containsNotes '[' ']' s ||
containsNotes '{' '}' s
conditionalEscapeText :: PandocMonad m
=> Text
-> Muse m Text
conditionalEscapeText :: forall (m :: * -> *). PandocMonad m => Text -> Muse m Text
conditionalEscapeText Text
s = do
shouldEscape <- Text -> Muse m Bool
forall (m :: * -> *). PandocMonad m => Text -> Muse m Bool
shouldEscapeText Text
s
return $ if shouldEscape
then escapeText s
else s
preprocessInlineList :: PandocMonad m
=> [Inline]
-> m [Inline]
preprocessInlineList :: forall (m :: * -> *). PandocMonad m => [Inline] -> m [Inline]
preprocessInlineList (Math MathType
t Text
str:[Inline]
xs) = [Inline] -> [Inline] -> [Inline]
forall a. [a] -> [a] -> [a]
(++) ([Inline] -> [Inline] -> [Inline])
-> m [Inline] -> m ([Inline] -> [Inline])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MathType -> Text -> m [Inline]
forall (m :: * -> *).
PandocMonad m =>
MathType -> Text -> m [Inline]
texMathToInlines MathType
t Text
str m ([Inline] -> [Inline]) -> m [Inline] -> m [Inline]
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Inline] -> m [Inline]
forall (m :: * -> *). PandocMonad m => [Inline] -> m [Inline]
preprocessInlineList [Inline]
xs
preprocessInlineList (Cite [Citation]
_ [Inline]
lst:[Inline]
xs) = ([Inline]
lst [Inline] -> [Inline] -> [Inline]
forall a. [a] -> [a] -> [a]
++) ([Inline] -> [Inline]) -> m [Inline] -> m [Inline]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Inline] -> m [Inline]
forall (m :: * -> *). PandocMonad m => [Inline] -> m [Inline]
preprocessInlineList [Inline]
xs
preprocessInlineList (Inline
x:[Inline]
xs) = (Inline
xInline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
:) ([Inline] -> [Inline]) -> m [Inline] -> m [Inline]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Inline] -> m [Inline]
forall (m :: * -> *). PandocMonad m => [Inline] -> m [Inline]
preprocessInlineList [Inline]
xs
preprocessInlineList [] = [Inline] -> m [Inline]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
replaceSmallCaps :: Inline -> Inline
replaceSmallCaps :: Inline -> Inline
replaceSmallCaps (SmallCaps [Inline]
lst) = [Inline] -> Inline
Emph [Inline]
lst
replaceSmallCaps Inline
x = Inline
x
removeKeyValues :: Inline -> Inline
removeKeyValues :: Inline -> Inline
removeKeyValues (Code (Text
i, [Text]
cls, [(Text, Text)]
_) Text
xs) = (Text, [Text], [(Text, Text)]) -> Text -> Inline
Code (Text
i, [Text]
cls, []) Text
xs
removeKeyValues Inline
x = Inline
x
normalizeInlineList :: [Inline] -> [Inline]
normalizeInlineList :: [Inline] -> [Inline]
normalizeInlineList (Str Text
"" : [Inline]
xs)
= [Inline] -> [Inline]
normalizeInlineList [Inline]
xs
normalizeInlineList (Inline
x : Str Text
"" : [Inline]
xs)
= [Inline] -> [Inline]
normalizeInlineList (Inline
xInline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
:[Inline]
xs)
normalizeInlineList (Str Text
x1 : Str Text
x2 : [Inline]
xs)
= [Inline] -> [Inline]
normalizeInlineList ([Inline] -> [Inline]) -> [Inline] -> [Inline]
forall a b. (a -> b) -> a -> b
$ Text -> Inline
Str (Text
x1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x2) Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
: [Inline]
xs
normalizeInlineList (Emph [Inline]
x1 : Emph [Inline]
x2 : [Inline]
ils)
= [Inline] -> [Inline]
normalizeInlineList ([Inline] -> [Inline]) -> [Inline] -> [Inline]
forall a b. (a -> b) -> a -> b
$ [Inline] -> Inline
Emph ([Inline]
x1 [Inline] -> [Inline] -> [Inline]
forall a. Semigroup a => a -> a -> a
<> [Inline]
x2) Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
: [Inline]
ils
normalizeInlineList (Strong [Inline]
x1 : Strong [Inline]
x2 : [Inline]
ils)
= [Inline] -> [Inline]
normalizeInlineList ([Inline] -> [Inline]) -> [Inline] -> [Inline]
forall a b. (a -> b) -> a -> b
$ [Inline] -> Inline
Strong ([Inline]
x1 [Inline] -> [Inline] -> [Inline]
forall a. Semigroup a => a -> a -> a
<> [Inline]
x2) Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
: [Inline]
ils
normalizeInlineList (Strikeout [Inline]
x1 : Strikeout [Inline]
x2 : [Inline]
ils)
= [Inline] -> [Inline]
normalizeInlineList ([Inline] -> [Inline]) -> [Inline] -> [Inline]
forall a b. (a -> b) -> a -> b
$ [Inline] -> Inline
Strikeout ([Inline]
x1 [Inline] -> [Inline] -> [Inline]
forall a. Semigroup a => a -> a -> a
<> [Inline]
x2) Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
: [Inline]
ils
normalizeInlineList (Superscript [Inline]
x1 : Superscript [Inline]
x2 : [Inline]
ils)
= [Inline] -> [Inline]
normalizeInlineList ([Inline] -> [Inline]) -> [Inline] -> [Inline]
forall a b. (a -> b) -> a -> b
$ [Inline] -> Inline
Superscript ([Inline]
x1 [Inline] -> [Inline] -> [Inline]
forall a. Semigroup a => a -> a -> a
<> [Inline]
x2) Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
: [Inline]
ils
normalizeInlineList (Subscript [Inline]
x1 : Subscript [Inline]
x2 : [Inline]
ils)
= [Inline] -> [Inline]
normalizeInlineList ([Inline] -> [Inline]) -> [Inline] -> [Inline]
forall a b. (a -> b) -> a -> b
$ [Inline] -> Inline
Subscript ([Inline]
x1 [Inline] -> [Inline] -> [Inline]
forall a. Semigroup a => a -> a -> a
<> [Inline]
x2) Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
: [Inline]
ils
normalizeInlineList (SmallCaps [Inline]
x1 : SmallCaps [Inline]
x2 : [Inline]
ils)
= [Inline] -> [Inline]
normalizeInlineList ([Inline] -> [Inline]) -> [Inline] -> [Inline]
forall a b. (a -> b) -> a -> b
$ [Inline] -> Inline
SmallCaps ([Inline]
x1 [Inline] -> [Inline] -> [Inline]
forall a. Semigroup a => a -> a -> a
<> [Inline]
x2) Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
: [Inline]
ils
normalizeInlineList (Code (Text, [Text], [(Text, Text)])
_ Text
x1 : Code (Text, [Text], [(Text, Text)])
_ Text
x2 : [Inline]
ils)
= [Inline] -> [Inline]
normalizeInlineList ([Inline] -> [Inline]) -> [Inline] -> [Inline]
forall a b. (a -> b) -> a -> b
$ (Text, [Text], [(Text, Text)]) -> Text -> Inline
Code (Text, [Text], [(Text, Text)])
nullAttr (Text
x1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x2) Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
: [Inline]
ils
normalizeInlineList (RawInline Format
f1 Text
x1 : RawInline Format
f2 Text
x2 : [Inline]
ils) | Format
f1 Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
== Format
f2
= [Inline] -> [Inline]
normalizeInlineList ([Inline] -> [Inline]) -> [Inline] -> [Inline]
forall a b. (a -> b) -> a -> b
$ Format -> Text -> Inline
RawInline Format
f1 (Text
x1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x2) Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
: [Inline]
ils
normalizeInlineList (Inline
x:[Inline]
xs) = Inline
x Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
: [Inline] -> [Inline]
normalizeInlineList [Inline]
xs
normalizeInlineList [] = []
fixNotes :: [Inline] -> [Inline]
fixNotes :: [Inline] -> [Inline]
fixNotes [] = []
fixNotes (Inline
Space : n :: Inline
n@Note{} : [Inline]
rest) = Text -> Inline
Str Text
" " Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
: Inline
n Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
: [Inline] -> [Inline]
fixNotes [Inline]
rest
fixNotes (Inline
SoftBreak : n :: Inline
n@Note{} : [Inline]
rest) = Text -> Inline
Str Text
" " Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
: Inline
n Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
: [Inline] -> [Inline]
fixNotes [Inline]
rest
fixNotes (Inline
x:[Inline]
xs) = Inline
x Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
: [Inline] -> [Inline]
fixNotes [Inline]
xs
startsWithSpace :: [Inline] -> Bool
startsWithSpace :: [Inline] -> Bool
startsWithSpace (Inline
Space:[Inline]
_) = Bool
True
startsWithSpace (Inline
SoftBreak:[Inline]
_) = Bool
True
startsWithSpace (Str Text
s:[Inline]
_) = Text -> Bool
stringStartsWithSpace Text
s
startsWithSpace [Inline]
_ = Bool
False
endsWithSpace :: [Inline] -> Bool
endsWithSpace :: [Inline] -> Bool
endsWithSpace [Inline
Space] = Bool
True
endsWithSpace [Inline
SoftBreak] = Bool
True
endsWithSpace [Str Text
s] = Text -> Bool
stringEndsWithSpace Text
s
endsWithSpace (Inline
_:[Inline]
xs) = [Inline] -> Bool
endsWithSpace [Inline]
xs
endsWithSpace [] = Bool
False
urlEscapeBrackets :: Text -> Text
urlEscapeBrackets :: Text -> Text
urlEscapeBrackets = (Char -> Text) -> Text -> Text
T.concatMap ((Char -> Text) -> Text -> Text) -> (Char -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ \Char
c -> case Char
c of
Char
']' -> Text
"%5D"
Char
_ -> Char -> Text
T.singleton Char
c
isHorizontalRule :: Text -> Bool
isHorizontalRule :: Text -> Bool
isHorizontalRule Text
s = Text -> Int
T.length Text
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
4 Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-') Text
s
stringStartsWithSpace :: Text -> Bool
stringStartsWithSpace :: Text -> Bool
stringStartsWithSpace = Bool -> ((Char, Text) -> Bool) -> Maybe (Char, Text) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Char -> Bool
isSpace (Char -> Bool) -> ((Char, Text) -> Char) -> (Char, Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char, Text) -> Char
forall a b. (a, b) -> a
fst) (Maybe (Char, Text) -> Bool)
-> (Text -> Maybe (Char, Text)) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe (Char, Text)
T.uncons
stringEndsWithSpace :: Text -> Bool
stringEndsWithSpace :: Text -> Bool
stringEndsWithSpace = Bool -> ((Text, Char) -> Bool) -> Maybe (Text, Char) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Char -> Bool
isSpace (Char -> Bool) -> ((Text, Char) -> Char) -> (Text, Char) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Char) -> Char
forall a b. (a, b) -> b
snd) (Maybe (Text, Char) -> Bool)
-> (Text -> Maybe (Text, Char)) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe (Text, Char)
T.unsnoc
fixOrEscape :: Bool -> Inline -> Bool
fixOrEscape :: Bool -> Inline -> Bool
fixOrEscape Bool
b (Str Text
s) = Bool -> Text -> Bool
fixOrEscapeStr Bool
b Text
s
where
fixOrEscapeStr :: Bool -> Text -> Bool
fixOrEscapeStr Bool
sp Text
t = case Text -> Maybe (Char, Text)
T.uncons Text
t of
Just (Char
'-', Text
xs)
| Text -> Bool
T.null Text
xs -> Bool
sp
| Bool
otherwise -> (Bool
sp Bool -> Bool -> Bool
&& Char -> Bool
isSpace (HasCallStack => Text -> Char
Text -> Char
T.head Text
xs)) Bool -> Bool -> Bool
|| Text -> Bool
isHorizontalRule Text
t
Just (Char
';', Text
xs)
| Text -> Bool
T.null Text
xs -> Bool -> Bool
not Bool
sp
| Bool
otherwise -> Bool -> Bool
not Bool
sp Bool -> Bool -> Bool
&& Char -> Bool
isSpace (HasCallStack => Text -> Char
Text -> Char
T.head Text
xs)
Just (Char
'>', Text
xs)
| Text -> Bool
T.null Text
xs -> Bool
True
| Bool
otherwise -> Char -> Bool
isSpace (HasCallStack => Text -> Char
Text -> Char
T.head Text
xs)
Maybe (Char, Text)
_ -> (Bool
sp Bool -> Bool -> Bool
&& ((Char -> Bool) -> Text -> Bool
startsWithMarker Char -> Bool
isDigit Text
s Bool -> Bool -> Bool
||
(Char -> Bool) -> Text -> Bool
startsWithMarker Char -> Bool
isAsciiLower Text
s Bool -> Bool -> Bool
||
(Char -> Bool) -> Text -> Bool
startsWithMarker Char -> Bool
isAsciiUpper Text
s))
Bool -> Bool -> Bool
|| Text -> Bool
stringStartsWithSpace Text
s
fixOrEscape Bool
_ Inline
Space = Bool
True
fixOrEscape Bool
_ Inline
SoftBreak = Bool
True
fixOrEscape Bool
_ Inline
_ = Bool
False
inlineListStartsWithAlnum :: PandocMonad m
=> [Inline]
-> Muse m Bool
inlineListStartsWithAlnum :: forall (m :: * -> *). PandocMonad m => [Inline] -> Muse m Bool
inlineListStartsWithAlnum (Str Text
s:[Inline]
_) = do
esc <- Text -> Muse m Bool
forall (m :: * -> *). PandocMonad m => Text -> Muse m Bool
shouldEscapeText Text
s
return $ esc || isAlphaNum (T.head s)
inlineListStartsWithAlnum [Inline]
_ = Bool -> Muse m Bool
forall a. a -> ReaderT WriterEnv (StateT WriterState m) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
renderInlineList :: PandocMonad m
=> [Inline]
-> Muse m (Doc Text)
renderInlineList :: forall (m :: * -> *).
PandocMonad m =>
[Inline] -> Muse m (Doc Text)
renderInlineList [] = Doc Text -> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall a. a -> ReaderT WriterEnv (StateT WriterState m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Doc Text
""
renderInlineList (Inline
x:[Inline]
xs) = do
start <- (WriterEnv -> Bool)
-> ReaderT WriterEnv (StateT WriterState m) Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Bool
envInlineStart
afterSpace <- asks envAfterSpace
topLevel <- asks envTopLevel
insideAsterisks <- asks envInsideAsterisks
nearAsterisks <- asks envNearAsterisks
useTags <- gets stUseTags
alnumNext <- inlineListStartsWithAlnum xs
let newUseTags = Bool
useTags Bool -> Bool -> Bool
|| Bool
alnumNext
modify $ \WriterState
st -> WriterState
st { stUseTags = newUseTags }
r <- local (\WriterEnv
env -> WriterEnv
env { envInlineStart = False
, envInsideAsterisks = False
, envNearAsterisks = nearAsterisks || (null xs && insideAsterisks)
}) $ inlineToMuse x
opts <- asks envOptions
let isNewline = (Inline
x Inline -> Inline -> Bool
forall a. Eq a => a -> a -> Bool
== Inline
SoftBreak Bool -> Bool -> Bool
&& WriterOptions -> WrapOption
writerWrapText WriterOptions
opts WrapOption -> WrapOption -> Bool
forall a. Eq a => a -> a -> Bool
== WrapOption
WrapPreserve) Bool -> Bool -> Bool
|| Inline
x Inline -> Inline -> Bool
forall a. Eq a => a -> a -> Bool
== Inline
LineBreak
lst' <- local (\WriterEnv
env -> WriterEnv
env { envInlineStart = isNewline
, envAfterSpace = x == Space || (not topLevel && isNewline)
, envNearAsterisks = False
}) $ renderInlineList xs
if start && fixOrEscape afterSpace x
then pure (literal "<verbatim></verbatim>" <> r <> lst')
else pure (r <> lst')
inlineListToMuse :: PandocMonad m
=> [Inline]
-> Muse m (Doc Text)
inlineListToMuse :: forall (m :: * -> *).
PandocMonad m =>
[Inline] -> Muse m (Doc Text)
inlineListToMuse [Inline]
lst = do
lst' <- [Inline] -> [Inline]
normalizeInlineList ([Inline] -> [Inline])
-> ([Inline] -> [Inline]) -> [Inline] -> [Inline]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Inline] -> [Inline]
fixNotes ([Inline] -> [Inline])
-> ReaderT WriterEnv (StateT WriterState m) [Inline]
-> ReaderT WriterEnv (StateT WriterState m) [Inline]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Inline] -> ReaderT WriterEnv (StateT WriterState m) [Inline]
forall (m :: * -> *). PandocMonad m => [Inline] -> m [Inline]
preprocessInlineList ((Inline -> Inline) -> [Inline] -> [Inline]
forall a b. (a -> b) -> [a] -> [b]
map (Inline -> Inline
removeKeyValues (Inline -> Inline) -> (Inline -> Inline) -> Inline -> Inline
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inline -> Inline
replaceSmallCaps) [Inline]
lst)
insideAsterisks <- asks envInsideAsterisks
start <- asks envInlineStart
modify $ \WriterState
st -> WriterState
st { stUseTags = False }
if start && null lst'
then pure "<verbatim></verbatim>"
else local (\WriterEnv
env -> WriterEnv
env { envNearAsterisks = insideAsterisks }) $ renderInlineList lst'
inlineListToMuse' :: PandocMonad m => [Inline] -> Muse m (Doc Text)
inlineListToMuse' :: forall (m :: * -> *).
PandocMonad m =>
[Inline] -> Muse m (Doc Text)
inlineListToMuse' [Inline]
lst = do
topLevel <- (WriterEnv -> Bool)
-> ReaderT WriterEnv (StateT WriterState m) Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Bool
envTopLevel
afterSpace <- asks envAfterSpace
local (\WriterEnv
env -> WriterEnv
env { envInlineStart = True
, envAfterSpace = afterSpace || not topLevel
}) $ inlineListToMuse lst
emphasis :: PandocMonad m => Text -> Text -> [Inline] -> Muse m (Doc Text)
emphasis :: forall (m :: * -> *).
PandocMonad m =>
Text -> Text -> [Inline] -> Muse m (Doc Text)
emphasis Text
b Text
e [Inline]
lst = do
contents <- (WriterEnv -> WriterEnv)
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall a.
(WriterEnv -> WriterEnv)
-> ReaderT WriterEnv (StateT WriterState m) a
-> ReaderT WriterEnv (StateT WriterState m) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\WriterEnv
env -> WriterEnv
env { envInsideAsterisks = inAsterisks }) (ReaderT WriterEnv (StateT WriterState m) (Doc Text)
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text))
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall a b. (a -> b) -> a -> b
$ [Inline] -> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
[Inline] -> Muse m (Doc Text)
inlineListToMuse [Inline]
lst
modify $ \WriterState
st -> WriterState
st { stUseTags = useTags }
return $ literal b <> contents <> literal e
where inAsterisks :: Bool
inAsterisks = HasCallStack => Text -> Char
Text -> Char
T.last Text
b Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'*' Bool -> Bool -> Bool
|| HasCallStack => Text -> Char
Text -> Char
T.head Text
e Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'*'
useTags :: Bool
useTags = HasCallStack => Text -> Char
Text -> Char
T.last Text
e Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'>'
inlineToMuse :: PandocMonad m
=> Inline
-> Muse m (Doc Text)
inlineToMuse :: forall (m :: * -> *). PandocMonad m => Inline -> Muse m (Doc Text)
inlineToMuse (Str Text
str) = do
escapedStr <- Text -> Muse m Text
forall (m :: * -> *). PandocMonad m => Text -> Muse m Text
conditionalEscapeText (Text -> Muse m Text) -> Text -> Muse m Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
replaceNewlines Text
str
let useTags = Char -> Bool
isAlphaNum (Char -> Bool) -> Char -> Bool
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Char
Text -> Char
T.last Text
escapedStr
modify $ \WriterState
st -> WriterState
st { stUseTags = useTags }
return $ literal escapedStr
inlineToMuse (Emph [Strong [Inline]
lst]) = do
useTags <- (WriterState -> Bool)
-> ReaderT WriterEnv (StateT WriterState m) Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Bool
stUseTags
let lst' = [Inline] -> [Inline]
normalizeInlineList [Inline]
lst
if useTags
then emphasis "<em>**" "**</em>" lst'
else if null lst' || startsWithSpace lst' || endsWithSpace lst'
then emphasis "*<strong>" "</strong>*" lst'
else emphasis "***" "***" lst'
inlineToMuse (Emph [Inline]
lst) = do
useTags <- (WriterState -> Bool)
-> ReaderT WriterEnv (StateT WriterState m) Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Bool
stUseTags
let lst' = [Inline] -> [Inline]
normalizeInlineList [Inline]
lst
if useTags || null lst' || startsWithSpace lst' || endsWithSpace lst'
then emphasis "<em>" "</em>" lst'
else emphasis "*" "*" lst'
inlineToMuse (Strong [Emph [Inline]
lst]) = do
useTags <- (WriterState -> Bool)
-> ReaderT WriterEnv (StateT WriterState m) Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Bool
stUseTags
let lst' = [Inline] -> [Inline]
normalizeInlineList [Inline]
lst
if useTags
then emphasis "<strong>*" "*</strong>" lst'
else if null lst' || startsWithSpace lst' || endsWithSpace lst'
then emphasis "**<em>" "</em>**" lst'
else emphasis "***" "***" lst'
inlineToMuse (Underline [Inline]
lst) = do
opts <- (WriterEnv -> WriterOptions)
-> ReaderT WriterEnv (StateT WriterState m) WriterOptions
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> WriterOptions
envOptions
contents <- inlineListToMuse lst
if isEnabled Ext_amuse opts
then return $ "_" <> contents <> "_"
else inlineToMuse (Emph lst)
inlineToMuse (Strong [Inline]
lst) = do
useTags <- (WriterState -> Bool)
-> ReaderT WriterEnv (StateT WriterState m) Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Bool
stUseTags
let lst' = [Inline] -> [Inline]
normalizeInlineList [Inline]
lst
if useTags || null lst' || startsWithSpace lst' || endsWithSpace lst'
then emphasis "<strong>" "</strong>" lst'
else emphasis "**" "**" lst'
inlineToMuse (Strikeout [Inline]
lst) = do
contents <- [Inline] -> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
[Inline] -> Muse m (Doc Text)
inlineListToMuse [Inline]
lst
modify $ \WriterState
st -> WriterState
st { stUseTags = False }
return $ "<del>" <> contents <> "</del>"
inlineToMuse (Superscript [Inline]
lst) = do
contents <- [Inline] -> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
[Inline] -> Muse m (Doc Text)
inlineListToMuse [Inline]
lst
modify $ \WriterState
st -> WriterState
st { stUseTags = False }
return $ "<sup>" <> contents <> "</sup>"
inlineToMuse (Subscript [Inline]
lst) = do
contents <- [Inline] -> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
[Inline] -> Muse m (Doc Text)
inlineListToMuse [Inline]
lst
modify $ \WriterState
st -> WriterState
st { stUseTags = False }
return $ "<sub>" <> contents <> "</sub>"
inlineToMuse SmallCaps {} =
PandocError -> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall a. PandocError -> ReaderT WriterEnv (StateT WriterState m) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text))
-> PandocError
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocShouldNeverHappenError
Text
"SmallCaps should be expanded before normalization"
inlineToMuse (Quoted QuoteType
SingleQuote [Inline]
lst) = do
contents <- [Inline] -> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
[Inline] -> Muse m (Doc Text)
inlineListToMuse [Inline]
lst
modify $ \WriterState
st -> WriterState
st { stUseTags = False }
return $ "‘" <> contents <> "’"
inlineToMuse (Quoted QuoteType
DoubleQuote [Inline]
lst) = do
contents <- [Inline] -> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
[Inline] -> Muse m (Doc Text)
inlineListToMuse [Inline]
lst
modify $ \WriterState
st -> WriterState
st { stUseTags = False }
return $ "“" <> contents <> "”"
inlineToMuse Cite {} =
PandocError -> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall a. PandocError -> ReaderT WriterEnv (StateT WriterState m) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text))
-> PandocError
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocShouldNeverHappenError
Text
"Citations should be expanded before normalization"
inlineToMuse (Code (Text, [Text], [(Text, Text)])
_ Text
str) = do
useTags <- (WriterState -> Bool)
-> ReaderT WriterEnv (StateT WriterState m) Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Bool
stUseTags
modify $ \WriterState
st -> WriterState
st { stUseTags = False }
return $ if useTags || T.null str || T.any (== '=') str
|| isSpace (T.head str) || isSpace (T.last str)
then "<code>" <> literal (T.replace "</code>" "<</code><code>/code>" str) <> "</code>"
else "=" <> literal str <> "="
inlineToMuse Math{} =
PandocError -> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall a. PandocError -> ReaderT WriterEnv (StateT WriterState m) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text))
-> PandocError
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocShouldNeverHappenError
Text
"Math should be expanded before normalization"
inlineToMuse (RawInline (Format Text
f) Text
str) = do
(WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ())
-> (WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall a b. (a -> b) -> a -> b
$ \WriterState
st -> WriterState
st { stUseTags = False }
Doc Text -> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall a. a -> ReaderT WriterEnv (StateT WriterState m) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> ReaderT WriterEnv (StateT WriterState m) (Doc Text))
-> Doc Text -> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall a b. (a -> b) -> a -> b
$ Doc Text
"<literal style=\"" Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal Text
f Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
"\">" Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal Text
str Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
"</literal>"
inlineToMuse Inline
LineBreak = do
oneline <- (WriterEnv -> Bool)
-> ReaderT WriterEnv (StateT WriterState m) Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Bool
envOneLine
modify $ \WriterState
st -> WriterState
st { stUseTags = False }
return $ if oneline then "<br>" else "<br>" <> cr
inlineToMuse Inline
Space = do
(WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ())
-> (WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall a b. (a -> b) -> a -> b
$ \WriterState
st -> WriterState
st { stUseTags = False }
Doc Text -> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall a. a -> ReaderT WriterEnv (StateT WriterState m) a
forall (m :: * -> *) a. Monad m => a -> m a
return Doc Text
forall a. Doc a
space
inlineToMuse Inline
SoftBreak = do
oneline <- (WriterEnv -> Bool)
-> ReaderT WriterEnv (StateT WriterState m) Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Bool
envOneLine
wrapText <- asks $ writerWrapText . envOptions
modify $ \WriterState
st -> WriterState
st { stUseTags = False }
return $ if not oneline && wrapText == WrapPreserve then cr else space
inlineToMuse (Link (Text, [Text], [(Text, Text)])
_ [Inline]
txt (Text
src, Text
_)) =
case [Inline]
txt of
[Str Text
x] | Text -> Text
escapeURI Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
src -> do
(WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ())
-> (WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall a b. (a -> b) -> a -> b
$ \WriterState
st -> WriterState
st { stUseTags = False }
Doc Text -> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall a. a -> ReaderT WriterEnv (StateT WriterState m) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> ReaderT WriterEnv (StateT WriterState m) (Doc Text))
-> Doc Text -> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall a b. (a -> b) -> a -> b
$ Doc Text
"[[" Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal (Text -> Text
escapeLink Text
x) Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
"]]"
[Inline]
_ -> do contents <- (WriterEnv -> WriterEnv)
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall a.
(WriterEnv -> WriterEnv)
-> ReaderT WriterEnv (StateT WriterState m) a
-> ReaderT WriterEnv (StateT WriterState m) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\WriterEnv
env -> WriterEnv
env { envInsideLinkDescription = True }) (ReaderT WriterEnv (StateT WriterState m) (Doc Text)
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text))
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
-> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall a b. (a -> b) -> a -> b
$ [Inline] -> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
[Inline] -> Muse m (Doc Text)
inlineListToMuse [Inline]
txt
modify $ \WriterState
st -> WriterState
st { stUseTags = False }
return $ "[[" <> literal (escapeLink src) <> "][" <> contents <> "]]"
where escapeLink :: Text -> Text
escapeLink Text
lnk = if Text -> Bool
isImageUrl Text
lnk then Text
"URL:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
urlEscapeBrackets Text
lnk else Text -> Text
urlEscapeBrackets Text
lnk
imageExtensions :: [String]
imageExtensions = [String
".eps", String
".gif", String
".jpg", String
".jpeg", String
".pbm", String
".png", String
".tiff", String
".xbm", String
".xpm"]
isImageUrl :: Text -> Bool
isImageUrl = (String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
imageExtensions) (String -> Bool) -> (Text -> String) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeExtension (String -> String) -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
inlineToMuse (Image (Text, [Text], [(Text, Text)])
attr [Inline]
alt (Text
source,Text -> Text -> Maybe Text
T.stripPrefix Text
"fig:" -> Just Text
title)) =
Inline -> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall (m :: * -> *). PandocMonad m => Inline -> Muse m (Doc Text)
inlineToMuse ((Text, [Text], [(Text, Text)])
-> [Inline] -> (Text, Text) -> Inline
Image (Text, [Text], [(Text, Text)])
attr [Inline]
alt (Text
source,Text
title))
inlineToMuse (Image attr :: (Text, [Text], [(Text, Text)])
attr@(Text
_, [Text]
classes, [(Text, Text)]
_) [Inline]
inlines (Text
source, Text
title)) = do
opts <- (WriterEnv -> WriterOptions)
-> ReaderT WriterEnv (StateT WriterState m) WriterOptions
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> WriterOptions
envOptions
alt <- local (\WriterEnv
env -> WriterEnv
env { envInsideLinkDescription = True }) $ inlineListToMuse inlines
title' <- if T.null title
then if null inlines
then return ""
else return $ "[" <> alt <> "]"
else do s <- local (\WriterEnv
env -> WriterEnv
env { envInsideLinkDescription = True }) $ conditionalEscapeText title
return $ "[" <> literal s <> "]"
let width = case Direction -> (Text, [Text], [(Text, Text)]) -> Maybe Dimension
dimension Direction
Width (Text, [Text], [(Text, Text)])
attr of
Just (Percent Double
x) | Extension -> WriterOptions -> Bool
forall a. HasSyntaxExtensions a => Extension -> a -> Bool
isEnabled Extension
Ext_amuse WriterOptions
opts -> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Integer -> Text
forall a. Show a => a -> Text
tshow (Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
x :: Integer)
Maybe Dimension
_ -> Text
""
let leftalign = if Text
"align-left" Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
classes
then Text
" l"
else Text
""
let rightalign = if Text
"align-right" Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
classes
then Text
" r"
else Text
""
modify $ \WriterState
st -> WriterState
st { stUseTags = False }
return $ "[[" <> literal (urlEscapeBrackets source <> width <> leftalign <> rightalign) <> "]" <> title' <> "]"
inlineToMuse (Note [Block]
contents) = do
notes <- (WriterState -> Notes)
-> ReaderT WriterEnv (StateT WriterState m) Notes
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Notes
stNotes
modify $ \WriterState
st -> WriterState
st { stNotes = contents:notes
, stUseTags = False
}
n <- gets stNoteNum
let ref = Int -> Text
forall a. Show a => a -> Text
tshow (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Notes -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Notes
notes
return $ "[" <> literal ref <> "]"
inlineToMuse (Span (Text
anchor,[Text]
names,[(Text, Text)]
kvs) [Inline]
inlines) = do
contents <- [Inline] -> ReaderT WriterEnv (StateT WriterState m) (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
[Inline] -> Muse m (Doc Text)
inlineListToMuse [Inline]
inlines
let (contents', hasDir) = case lookup "dir" kvs of
Just Text
"rtl" -> (Doc Text
"<<<" Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
contents Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
">>>", Bool
True)
Just Text
"ltr" -> (Doc Text
">>>" Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
contents Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
"<<<", Bool
True)
Maybe Text
_ -> (Doc Text
contents, Bool
False)
let anchorDoc = if Text -> Bool
T.null Text
anchor
then Doc Text
forall a. Monoid a => a
mempty
else Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal (Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
anchor) Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
forall a. Doc a
space
modify $ \WriterState
st -> WriterState
st { stUseTags = False }
return $ anchorDoc <>
if null inlines && not (T.null anchor)
then mempty
else case names of
[] | Bool
hasDir -> Doc Text
contents'
| Bool
otherwise -> Doc Text
"<class>" Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
contents' Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
"</class>"
(Text
n:[Text]
_) -> Doc Text
"<class name=\"" Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal Text
n Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
"\">" Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<>
Doc Text
contents' Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
"</class>"