{-# 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.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
  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 $ renderWithTemplate opts context main

-- | 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 thead :: TableHead
thead@(TableHead (Text, [Text], [(Text, Text)])
hattr [Row]
hrows) [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
      let tbody' = case [Row]
hrows of
                     [] -> [TableBody]
tbody
                     [Row]
_  -> (Text, [Text], [(Text, Text)])
-> RowHeadColumns -> [Row] -> [Row] -> TableBody
TableBody (Text, [Text], [(Text, Text)])
nullAttr RowHeadColumns
0 [] [Row]
hrows TableBody -> [TableBody] -> [TableBody]
forall a. a -> [a] -> [a]
: [TableBody]
tbody
      gridTable opts blocksToDoc specs (TableHead hattr []) tbody' tfoot
  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>"