{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns      #-}
{- |
   Module      : Text.Pandoc.Writers.Muse
   Copyright   : Copyright (C) 2017-2020 Alexander Krotov
   License     : GNU GPL, version 2 or above

   Maintainer  : Alexander Krotov <ilabdsf@gmail.com>
   Stability   : stable
   Portability : portable

Conversion of 'Pandoc' documents to Muse.

This module is mostly intended for <https://amusewiki.org/ Amusewiki> markup support,
as described by <https://amusewiki.org/library/manual Text::Amuse markup manual>.
Original <https://www.gnu.org/software/emacs-muse/ Emacs Muse> markup support
is a secondary goal.

Where Text::Amuse markup
<https://metacpan.org/pod/Text::Amuse#DIFFERENCES-WITH-THE-ORIGINAL-EMACS-MUSE-MARKUP differs>
from <https://www.gnu.org/software/emacs-muse/manual/ Emacs Muse markup>,
Text::Amuse markup is supported.
For example, native tables are always used instead of Org Mode tables.
However, @\<literal style="html">@ tag is used for HTML raw blocks
even though it is supported only in Emacs Muse.
-}
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 -- ^ True if there is only whitespace since last newline
            , WriterEnv -> Bool
envInsideLinkDescription :: Bool -- ^ Escape ] if True
            , WriterEnv -> Bool
envAfterSpace            :: Bool -- ^ There is whitespace (not just newline) before
            , WriterEnv -> Bool
envOneLine               :: Bool -- ^ True if newlines are not allowed
            , WriterEnv -> Bool
envInsideAsterisks       :: Bool -- ^ True if outer element is emphasis with asterisks
            , WriterEnv -> Bool
envNearAsterisks         :: Bool -- ^ Rendering inline near asterisks
            }

data WriterState =
  WriterState { WriterState -> Notes
stNotes   :: Notes
              , WriterState -> Int
stNoteNum :: Int
              , WriterState -> Set Text
stIds     :: Set.Set Text
              , WriterState -> Bool
stUseTags :: Bool -- ^ Use tags for emphasis, for example because previous character is a letter
              }

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

-- | Convert Pandoc to Muse.
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
                        }

-- | Return Muse representation of document.
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

-- | Helper function for flatBlockListToMuse
-- | Render all blocks and insert blank lines between the first two
catWithBlankLines :: PandocMonad m
                  => [Block]       -- ^ List of block elements
                  -> Int           -- ^ Number of blank lines
                  -> 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"

-- | Convert list of Pandoc block elements to Muse
-- | without setting envTopLevel.
flatBlockListToMuse :: PandocMonad m
                => [Block]       -- ^ List of block elements
                -> 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
" |  "

-- | Convert list of Pandoc block elements to Muse.
blockListToMuse :: PandocMonad m
                => [Block]       -- ^ List of block elements
                -> 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

-- | Convert Pandoc block element to Muse.
blockToMuse :: PandocMonad m
            => Block         -- ^ Block element
            -> 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 -- nest 0 to remove trailing blank lines
        $$ "</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     -- marker for list item
                              -> [Block]  -- list item (list of blocks)
                              -> 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' -- using Text.DocLayout.offset results in round trip failures
          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
-- https://www.gnu.org/software/emacs-muse/manual/muse.html#Horizontal-Rules-and-Anchors
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)

-- | Return Muse representation of notes collected so far.
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

-- | Return Muse representation of 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

-- | Return Muse representation of a note.
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
"] "

-- | Return Muse representation of block and accumulated notes.
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

-- | Escape special characters for Muse.
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>"

-- | Replace newlines with spaces
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 -- This ought to be a parser
  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

-- | Return True if string should be escaped with <verbatim> tags
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

-- | Escape special characters for Muse if needed.
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

-- Expand Math and Cite before normalizing inline list
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
-- Amusewiki does not support <cite> tag,
-- and Emacs Muse citation support is limited
-- (https://www.gnu.org/software/emacs-muse/manual/html_node/Citations.html#Citation)
-- so just fallback to expanding inlines.
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
-- Do not remove attributes from Link
-- Do not remove attributes, such as "width", from Image
-- Do not remove attributes, such as "dir", from Span
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
-- Do not join Span's during normalization
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

-- | Convert list of Pandoc inline elements to Muse
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')

-- | Normalize and convert list of Pandoc inline elements to Muse.
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 } -- Previous character is likely a '>' or some other markup
  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
'>'

-- | Convert Pandoc inline element to Muse.
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 -- escapedStr is never empty because empty strings are escaped
  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'
-- Underline is only supported in Emacs Muse mode.
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
        -- Taken from muse-image-regexp defined in Emacs Muse file lisp/muse-regexps.el
        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
  -- add to notes in state
  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>"