Add Muse reader (#3620)
This commit is contained in:
Alexander Krotov
John MacFarlane
parent
10e3ce361f
commit
a91b9b2a1d
6 changed files with 849 additions and 0 deletions
|
|
@ -380,6 +380,7 @@ Library
|
|||
Text.Pandoc.Readers.Docx,
|
||||
Text.Pandoc.Readers.Odt,
|
||||
Text.Pandoc.Readers.EPUB,
|
||||
Text.Pandoc.Readers.Muse,
|
||||
Text.Pandoc.Writers,
|
||||
Text.Pandoc.Writers.Native,
|
||||
Text.Pandoc.Writers.Docbook,
|
||||
|
|
@ -559,6 +560,7 @@ Test-Suite test-pandoc
|
|||
Tests.Readers.Odt
|
||||
Tests.Readers.Txt2Tags
|
||||
Tests.Readers.EPUB
|
||||
Tests.Readers.Muse
|
||||
Tests.Writers.Native
|
||||
Tests.Writers.ConTeXt
|
||||
Tests.Writers.Docbook
|
||||
|
|
|
|||
|
|
@ -59,6 +59,7 @@ module Text.Pandoc.Readers
|
|||
, readTWiki
|
||||
, readTxt2Tags
|
||||
, readEPUB
|
||||
, readMuse
|
||||
-- * Miscellaneous
|
||||
, getReader
|
||||
, getDefaultExtensions
|
||||
|
|
@ -81,6 +82,7 @@ import Text.Pandoc.Readers.HTML
|
|||
import Text.Pandoc.Readers.LaTeX
|
||||
import Text.Pandoc.Readers.Markdown
|
||||
import Text.Pandoc.Readers.MediaWiki
|
||||
import Text.Pandoc.Readers.Muse
|
||||
import Text.Pandoc.Readers.Native
|
||||
import Text.Pandoc.Readers.Odt
|
||||
import Text.Pandoc.Readers.OPML
|
||||
|
|
@ -125,6 +127,7 @@ readers = [ ("native" , TextReader readNative)
|
|||
,("odt" , ByteStringReader readOdt)
|
||||
,("t2t" , TextReader readTxt2Tags)
|
||||
,("epub" , ByteStringReader readEPUB)
|
||||
,("muse" , TextReader readMuse)
|
||||
]
|
||||
|
||||
-- | Retrieve reader based on formatSpec (format+extensions).
|
||||
|
|
|
|||
577
src/Text/Pandoc/Readers/Muse.hs
Normal file
577
src/Text/Pandoc/Readers/Muse.hs
Normal file
|
|
@ -0,0 +1,577 @@
|
|||
{-
|
||||
Copyright (C) 2017 Alexander Krotov <ilabdsf@gmail.com>
|
||||
|
||||
This program is free software; you can redistribute it and/or modify
|
||||
it under the terms of the GNU General Public License as published by
|
||||
the Free Software Foundation; either version 2 of the License, or
|
||||
(at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License
|
||||
along with this program; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
-}
|
||||
|
||||
{- |
|
||||
Module : Text.Pandoc.Readers.Muse
|
||||
Copyright : Copyright (C) 2017 Alexander Krotov
|
||||
License : GNU GPL, version 2 or above
|
||||
|
||||
Maintainer : Alexander Krotov <ilabdsf@gmail.com>
|
||||
Stability : alpha
|
||||
Portability : portable
|
||||
|
||||
Conversion of Muse text to 'Pandoc' document.
|
||||
-}
|
||||
{-
|
||||
TODO:
|
||||
- {{{ }}} syntax for <example>
|
||||
- Page breaks (five "*")
|
||||
- Headings with anchors (make it round trip with Muse writer)
|
||||
- <verse> and ">"
|
||||
- Definition lists
|
||||
- Org tables
|
||||
- table.el tables
|
||||
- Images with attributes (floating and width)
|
||||
- Anchors
|
||||
- Citations and <biblio>
|
||||
- <play> environment
|
||||
- <verbatim> tag
|
||||
-}
|
||||
module Text.Pandoc.Readers.Muse (readMuse) where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.Except (throwError)
|
||||
import qualified Data.Map as M
|
||||
import Data.Text (Text, unpack)
|
||||
import Data.List (stripPrefix)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Text.HTML.TagSoup
|
||||
import Text.Pandoc.Builder (Blocks, Inlines)
|
||||
import qualified Text.Pandoc.Builder as B
|
||||
import Text.Pandoc.Class (PandocMonad, report)
|
||||
import Text.Pandoc.Definition
|
||||
import Text.Pandoc.Logging
|
||||
import Text.Pandoc.Options
|
||||
import Text.Pandoc.Parsing hiding (macro, nested)
|
||||
import Text.Pandoc.Readers.HTML (htmlTag)
|
||||
import Text.Pandoc.XML (fromEntities)
|
||||
import System.FilePath (takeExtension)
|
||||
|
||||
-- | Read Muse from an input string and return a Pandoc document.
|
||||
readMuse :: PandocMonad m
|
||||
=> ReaderOptions
|
||||
-> Text
|
||||
-> m Pandoc
|
||||
readMuse opts s = do
|
||||
res <- readWithM parseMuse def{ stateOptions = opts } (unpack s)
|
||||
case res of
|
||||
Left e -> throwError e
|
||||
Right d -> return d
|
||||
|
||||
type MuseParser = ParserT String ParserState
|
||||
|
||||
--
|
||||
-- main parser
|
||||
--
|
||||
|
||||
parseMuse :: PandocMonad m => MuseParser m Pandoc
|
||||
parseMuse = do
|
||||
many directive
|
||||
blocks <- parseBlocks
|
||||
st <- getState
|
||||
let doc = runF (do Pandoc _ bs <- B.doc <$> blocks
|
||||
meta <- stateMeta' st
|
||||
return $ Pandoc meta bs) st
|
||||
reportLogMessages
|
||||
return doc
|
||||
|
||||
parseBlocks :: PandocMonad m => MuseParser m (F Blocks)
|
||||
parseBlocks = do
|
||||
res <- mconcat <$> many block
|
||||
spaces
|
||||
eof
|
||||
return res
|
||||
|
||||
--
|
||||
-- utility functions
|
||||
--
|
||||
|
||||
nested :: PandocMonad m => MuseParser m a -> MuseParser m a
|
||||
nested p = do
|
||||
nestlevel <- stateMaxNestingLevel <$> getState
|
||||
guard $ nestlevel > 0
|
||||
updateState $ \st -> st{ stateMaxNestingLevel = stateMaxNestingLevel st - 1 }
|
||||
res <- p
|
||||
updateState $ \st -> st{ stateMaxNestingLevel = nestlevel }
|
||||
return res
|
||||
|
||||
htmlElement :: PandocMonad m => String -> MuseParser m (Attr, String)
|
||||
htmlElement tag = try $ do
|
||||
(TagOpen _ attr, _) <- htmlTag (~== TagOpen tag [])
|
||||
content <- manyTill anyChar (endtag <|> endofinput)
|
||||
return (htmlAttrToPandoc attr, trim content)
|
||||
where
|
||||
endtag = void $ htmlTag (~== TagClose tag)
|
||||
endofinput = lookAhead $ try $ skipMany blankline >> skipSpaces >> eof
|
||||
trim = dropWhile (=='\n') . reverse . dropWhile (=='\n') . reverse
|
||||
|
||||
htmlAttrToPandoc :: [Attribute String] -> Attr
|
||||
htmlAttrToPandoc attrs = (ident, classes, keyvals)
|
||||
where
|
||||
ident = fromMaybe "" $ lookup "id" attrs
|
||||
classes = maybe [] words $ lookup "class" attrs
|
||||
keyvals = [(k,v) | (k,v) <- attrs, k /= "id" && k /= "class"]
|
||||
|
||||
parseHtmlContentWithAttrs :: PandocMonad m
|
||||
=> String -> MuseParser m a -> MuseParser m (Attr, [a])
|
||||
parseHtmlContentWithAttrs tag parser = do
|
||||
(attr, content) <- htmlElement tag
|
||||
parsedContent <- try $ parseContent content
|
||||
return (attr, parsedContent)
|
||||
where
|
||||
parseContent = parseFromString $ nested $ manyTill parser endOfContent
|
||||
endOfContent = try $ skipMany blankline >> skipSpaces >> eof
|
||||
|
||||
parseHtmlContent :: PandocMonad m => String -> MuseParser m a -> MuseParser m [a]
|
||||
parseHtmlContent tag p = liftM snd (parseHtmlContentWithAttrs tag p)
|
||||
|
||||
--
|
||||
-- directive parsers
|
||||
--
|
||||
|
||||
parseDirective :: PandocMonad m => MuseParser m (String, F Inlines)
|
||||
parseDirective = do
|
||||
char '#'
|
||||
key <- many letter
|
||||
space
|
||||
spaces
|
||||
raw <- many $ noneOf "\n"
|
||||
newline
|
||||
value <- parseFromString (trimInlinesF . mconcat <$> many inline) raw
|
||||
return (key, value)
|
||||
|
||||
directive :: PandocMonad m => MuseParser m ()
|
||||
directive = do
|
||||
(key, value) <- parseDirective
|
||||
updateState $ \st -> st { stateMeta' = B.setMeta key <$> value <*> stateMeta' st }
|
||||
|
||||
--
|
||||
-- block parsers
|
||||
--
|
||||
|
||||
block :: PandocMonad m => MuseParser m (F Blocks)
|
||||
block = do
|
||||
pos <- getPosition
|
||||
res <- mempty <$ skipMany1 blankline
|
||||
<|> blockElements
|
||||
<|> para
|
||||
skipMany blankline
|
||||
report $ ParsingTrace (take 60 $ show $ B.toList $ runF res defaultParserState) pos
|
||||
return res
|
||||
|
||||
blockElements :: PandocMonad m => MuseParser m (F Blocks)
|
||||
blockElements = choice [ comment
|
||||
, separator
|
||||
, header
|
||||
, exampleTag
|
||||
, literal
|
||||
, centerTag
|
||||
, rightTag
|
||||
, quoteTag
|
||||
, bulletList
|
||||
, orderedList
|
||||
, table
|
||||
, commentTag
|
||||
, noteBlock
|
||||
]
|
||||
|
||||
comment :: PandocMonad m => MuseParser m (F Blocks)
|
||||
comment = try $ do
|
||||
char ';'
|
||||
space
|
||||
many $ noneOf "\n"
|
||||
void newline <|> eof
|
||||
return mempty
|
||||
|
||||
separator :: PandocMonad m => MuseParser m (F Blocks)
|
||||
separator = try $ do
|
||||
string "---"
|
||||
newline
|
||||
return $ return B.horizontalRule
|
||||
|
||||
header :: PandocMonad m => MuseParser m (F Blocks)
|
||||
header = try $ do
|
||||
level <- liftM length $ many1 $ char '*'
|
||||
guard $ level <= 5
|
||||
skipSpaces
|
||||
content <- trimInlinesF . mconcat <$> manyTill inline newline
|
||||
attr <- registerHeader ("", [], []) (runF content defaultParserState)
|
||||
return $ B.headerWith attr level <$> content
|
||||
|
||||
exampleTag :: PandocMonad m => MuseParser m (F Blocks)
|
||||
exampleTag = liftM (return . uncurry B.codeBlockWith) $ htmlElement "example"
|
||||
|
||||
literal :: PandocMonad m => MuseParser m (F Blocks)
|
||||
literal = liftM (return . rawBlock) $ htmlElement "literal"
|
||||
where
|
||||
format (_, _, kvs) = fromMaybe "html" $ lookup "format" kvs
|
||||
rawBlock (attrs, content) = B.rawBlock (format attrs) content
|
||||
|
||||
blockTag :: PandocMonad m
|
||||
=> (Blocks -> Blocks)
|
||||
-> String
|
||||
-> MuseParser m (F Blocks)
|
||||
blockTag f s = do
|
||||
res <- parseHtmlContent s block
|
||||
return $ f <$> mconcat res
|
||||
|
||||
-- <center> tag is ignored
|
||||
centerTag :: PandocMonad m => MuseParser m (F Blocks)
|
||||
centerTag = blockTag id "center"
|
||||
|
||||
-- <right> tag is ignored
|
||||
rightTag :: PandocMonad m => MuseParser m (F Blocks)
|
||||
rightTag = blockTag id "right"
|
||||
|
||||
quoteTag :: PandocMonad m => MuseParser m (F Blocks)
|
||||
quoteTag = blockTag B.blockQuote "quote"
|
||||
|
||||
commentTag :: PandocMonad m => MuseParser m (F Blocks)
|
||||
commentTag = parseHtmlContent "comment" block >> return mempty
|
||||
|
||||
para :: PandocMonad m => MuseParser m (F Blocks)
|
||||
para = do
|
||||
res <- trimInlinesF . mconcat <$> many1Till inline endOfParaElement
|
||||
return $ B.para <$> res
|
||||
where
|
||||
endOfParaElement = lookAhead $ endOfInput <|> endOfPara <|> newBlockElement
|
||||
endOfInput = try $ skipMany blankline >> skipSpaces >> eof
|
||||
endOfPara = try $ blankline >> skipMany1 blankline
|
||||
newBlockElement = try $ blankline >> void blockElements
|
||||
|
||||
noteMarker :: PandocMonad m => MuseParser m String
|
||||
noteMarker = try $ do
|
||||
char '['
|
||||
many1Till digit $ char ']'
|
||||
|
||||
noteBlock :: PandocMonad m => MuseParser m (F Blocks)
|
||||
noteBlock = try $ do
|
||||
pos <- getPosition
|
||||
ref <- noteMarker <* skipSpaces
|
||||
content <- mconcat <$> blocksTillNote
|
||||
oldnotes <- stateNotes' <$> getState
|
||||
case M.lookup ref oldnotes of
|
||||
Just _ -> logMessage $ DuplicateNoteReference ref pos
|
||||
Nothing -> return ()
|
||||
updateState $ \s -> s{ stateNotes' = M.insert ref (pos, content) oldnotes }
|
||||
return mempty
|
||||
where
|
||||
blocksTillNote =
|
||||
many1Till block (eof <|> () <$ lookAhead noteMarker)
|
||||
|
||||
--
|
||||
-- lists
|
||||
--
|
||||
|
||||
listLine :: PandocMonad m => Int -> MuseParser m String
|
||||
listLine markerLength = try $ do
|
||||
notFollowedBy blankline
|
||||
indentWith markerLength
|
||||
anyLineNewline
|
||||
|
||||
withListContext :: PandocMonad m => MuseParser m a -> MuseParser m a
|
||||
withListContext p = do
|
||||
state <- getState
|
||||
let oldContext = stateParserContext state
|
||||
setState $ state { stateParserContext = ListItemState }
|
||||
parsed <- p
|
||||
updateState (\st -> st {stateParserContext = oldContext})
|
||||
return parsed
|
||||
|
||||
listContinuation :: PandocMonad m => Int -> MuseParser m String
|
||||
listContinuation markerLength = try $ do
|
||||
result <- many1 $ listLine markerLength
|
||||
blanks <- many1 blankline
|
||||
return $ concat result ++ blanks
|
||||
|
||||
listStart :: PandocMonad m => MuseParser m Int -> MuseParser m Int
|
||||
listStart marker = try $ do
|
||||
preWhitespace <- length <$> many spaceChar
|
||||
st <- stateParserContext <$> getState
|
||||
getPosition >>= \pos -> guard (st == ListItemState || sourceColumn pos /= 1)
|
||||
markerLength <- marker
|
||||
postWhitespace <- length <$> many1 spaceChar
|
||||
return $ preWhitespace + markerLength + postWhitespace
|
||||
|
||||
listItem :: PandocMonad m => MuseParser m Int -> MuseParser m (F Blocks)
|
||||
listItem start = try $ do
|
||||
markerLength <- start
|
||||
firstLine <- anyLineNewline
|
||||
blank <- option "" ("\n" <$ blankline)
|
||||
restLines <- many $ listLine markerLength
|
||||
let first = firstLine ++ blank ++ concat restLines
|
||||
rest <- many $ listContinuation markerLength
|
||||
parseFromString (withListContext parseBlocks) $ concat (first:rest) ++ "\n"
|
||||
|
||||
bulletListItems :: PandocMonad m => MuseParser m (F [Blocks])
|
||||
bulletListItems = sequence <$> many1 (listItem bulletListStart)
|
||||
|
||||
bulletListStart :: PandocMonad m => MuseParser m Int
|
||||
bulletListStart = listStart (char '-' >> return 1)
|
||||
|
||||
bulletList :: PandocMonad m => MuseParser m (F Blocks)
|
||||
bulletList = do
|
||||
listItems <- bulletListItems
|
||||
return $ B.bulletList <$> listItems
|
||||
|
||||
orderedListStart :: PandocMonad m
|
||||
=> ListNumberStyle
|
||||
-> ListNumberDelim
|
||||
-> MuseParser m Int
|
||||
orderedListStart style delim = listStart (snd <$> withHorizDisplacement (orderedListMarker style delim))
|
||||
|
||||
orderedList :: PandocMonad m => MuseParser m (F Blocks)
|
||||
orderedList = try $ do
|
||||
p@(_, style, delim) <- lookAhead (many spaceChar *> anyOrderedListMarker <* spaceChar)
|
||||
guard $ style `elem` [Decimal, LowerAlpha, UpperAlpha, LowerRoman, UpperRoman]
|
||||
guard $ delim == Period
|
||||
items <- sequence <$> many1 (listItem $ orderedListStart style delim)
|
||||
return $ B.orderedListWith p <$> items
|
||||
|
||||
--
|
||||
-- tables
|
||||
--
|
||||
|
||||
data MuseTable = MuseTable
|
||||
{ museTableCaption :: Inlines
|
||||
, museTableHeaders :: [[Blocks]]
|
||||
, museTableRows :: [[Blocks]]
|
||||
, museTableFooters :: [[Blocks]]
|
||||
}
|
||||
|
||||
data MuseTableElement = MuseHeaderRow (F [Blocks])
|
||||
| MuseBodyRow (F [Blocks])
|
||||
| MuseFooterRow (F [Blocks])
|
||||
| MuseCaption (F Inlines)
|
||||
|
||||
museToPandocTable :: MuseTable -> Blocks
|
||||
museToPandocTable (MuseTable caption headers body footers) =
|
||||
B.table caption attrs headRow rows
|
||||
where ncol = maximum (0 : map length (headers ++ body ++ footers))
|
||||
attrs = replicate ncol (AlignDefault, 0.0)
|
||||
headRow = if null headers then [] else head headers
|
||||
rows = (if null headers then [] else tail headers) ++ body ++ footers
|
||||
|
||||
museAppendElement :: MuseTable
|
||||
-> MuseTableElement
|
||||
-> F MuseTable
|
||||
museAppendElement tbl element =
|
||||
case element of
|
||||
MuseHeaderRow row -> do
|
||||
row' <- row
|
||||
return tbl{ museTableHeaders = museTableHeaders tbl ++ [row'] }
|
||||
MuseBodyRow row -> do
|
||||
row' <- row
|
||||
return tbl{ museTableRows = museTableRows tbl ++ [row'] }
|
||||
MuseFooterRow row-> do
|
||||
row' <- row
|
||||
return tbl{ museTableFooters = museTableFooters tbl ++ [row'] }
|
||||
MuseCaption inlines -> do
|
||||
inlines' <- inlines
|
||||
return tbl{ museTableCaption = inlines' }
|
||||
|
||||
tableCell :: PandocMonad m => MuseParser m (F Blocks)
|
||||
tableCell = try $ do
|
||||
content <- trimInlinesF . mconcat <$> manyTill inline (lookAhead cellEnd)
|
||||
return $ B.plain <$> content
|
||||
where cellEnd = try $ void (many1 spaceChar >> char '|') <|> void newline <|> eof
|
||||
|
||||
tableElements :: PandocMonad m => MuseParser m [MuseTableElement]
|
||||
tableElements = tableParseElement `sepEndBy1` (void newline <|> eof)
|
||||
|
||||
elementsToTable :: [MuseTableElement] -> F MuseTable
|
||||
elementsToTable = foldM museAppendElement emptyTable
|
||||
where emptyTable = MuseTable mempty mempty mempty mempty
|
||||
|
||||
table :: PandocMonad m => MuseParser m (F Blocks)
|
||||
table = try $ do
|
||||
rows <- tableElements
|
||||
let tbl = elementsToTable rows
|
||||
let pandocTbl = museToPandocTable <$> tbl :: F Blocks
|
||||
return pandocTbl
|
||||
|
||||
tableParseElement :: PandocMonad m => MuseParser m MuseTableElement
|
||||
tableParseElement = tableParseHeader
|
||||
<|> tableParseBody
|
||||
<|> tableParseFooter
|
||||
<|> tableParseCaption
|
||||
|
||||
tableParseRow :: PandocMonad m => Int -> MuseParser m (F [Blocks])
|
||||
tableParseRow n = try $ do
|
||||
fields <- tableCell `sepBy2` fieldSep
|
||||
return $ sequence fields
|
||||
where p `sepBy2` sep = (:) <$> p <*> many1 (sep >> p)
|
||||
fieldSep = many1 spaceChar >> count n (char '|') >> (void (many1 spaceChar) <|> void (lookAhead newline))
|
||||
|
||||
tableParseHeader :: PandocMonad m => MuseParser m MuseTableElement
|
||||
tableParseHeader = MuseHeaderRow <$> tableParseRow 2
|
||||
|
||||
tableParseBody :: PandocMonad m => MuseParser m MuseTableElement
|
||||
tableParseBody = MuseBodyRow <$> tableParseRow 1
|
||||
|
||||
tableParseFooter :: PandocMonad m => MuseParser m MuseTableElement
|
||||
tableParseFooter = MuseFooterRow <$> tableParseRow 3
|
||||
|
||||
tableParseCaption :: PandocMonad m => MuseParser m MuseTableElement
|
||||
tableParseCaption = try $ do
|
||||
many spaceChar
|
||||
string "|+"
|
||||
contents <- trimInlinesF . mconcat <$> many1Till inline (lookAhead $ string "+|")
|
||||
string "+|"
|
||||
return $ MuseCaption contents
|
||||
|
||||
--
|
||||
-- inline parsers
|
||||
--
|
||||
|
||||
inline :: PandocMonad m => MuseParser m (F Inlines)
|
||||
inline = choice [ whitespace
|
||||
, br
|
||||
, footnote
|
||||
, strong
|
||||
, strongTag
|
||||
, emph
|
||||
, emphTag
|
||||
, superscriptTag
|
||||
, subscriptTag
|
||||
, strikeoutTag
|
||||
, link
|
||||
, code
|
||||
, codeTag
|
||||
, str
|
||||
, symbol
|
||||
] <?> "inline"
|
||||
|
||||
footnote :: PandocMonad m => MuseParser m (F Inlines)
|
||||
footnote = try $ do
|
||||
ref <- noteMarker
|
||||
return $ do
|
||||
notes <- asksF stateNotes'
|
||||
case M.lookup ref notes of
|
||||
Nothing -> return $ B.str $ "[" ++ ref ++ "]"
|
||||
Just (_pos, contents) -> do
|
||||
st <- askF
|
||||
let contents' = runF contents st { stateNotes' = M.empty }
|
||||
return $ B.note contents'
|
||||
|
||||
whitespace :: PandocMonad m => MuseParser m (F Inlines)
|
||||
whitespace = liftM return (lb <|> regsp)
|
||||
where lb = try $ skipMany spaceChar >> linebreak >> return B.space
|
||||
regsp = try $ skipMany1 spaceChar >> return B.space
|
||||
|
||||
br :: PandocMonad m => MuseParser m (F Inlines)
|
||||
br = try $ do
|
||||
string "<br>"
|
||||
return $ return B.linebreak
|
||||
|
||||
linebreak :: PandocMonad m => MuseParser m (F Inlines)
|
||||
linebreak = newline >> notFollowedBy newline >> (lastNewline <|> innerNewline)
|
||||
where lastNewline = do
|
||||
eof
|
||||
return $ return mempty
|
||||
innerNewline = return $ return B.space
|
||||
|
||||
emphasisBetween :: (PandocMonad m, Show a) => MuseParser m a -> MuseParser m (F Inlines)
|
||||
emphasisBetween c = try $ enclosedInlines c c
|
||||
|
||||
enclosedInlines :: (PandocMonad m, Show a, Show b)
|
||||
=> MuseParser m a
|
||||
-> MuseParser m b
|
||||
-> MuseParser m (F Inlines)
|
||||
enclosedInlines start end = try $
|
||||
trimInlinesF . mconcat <$> enclosed start end inline
|
||||
|
||||
verbatimBetween :: PandocMonad m
|
||||
=> Char
|
||||
-> MuseParser m String
|
||||
verbatimBetween c = try $ do
|
||||
char c
|
||||
many1Till anyChar $ char c
|
||||
|
||||
inlineTag :: PandocMonad m
|
||||
=> (Inlines -> Inlines)
|
||||
-> String
|
||||
-> MuseParser m (F Inlines)
|
||||
inlineTag f s = do
|
||||
res <- parseHtmlContent s inline
|
||||
return $ f <$> mconcat res
|
||||
|
||||
strongTag :: PandocMonad m => MuseParser m (F Inlines)
|
||||
strongTag = inlineTag B.strong "strong"
|
||||
|
||||
strong :: PandocMonad m => MuseParser m (F Inlines)
|
||||
strong = fmap B.strong <$> emphasisBetween (string "**")
|
||||
|
||||
emph :: PandocMonad m => MuseParser m (F Inlines)
|
||||
emph = fmap B.emph <$> emphasisBetween (char '*')
|
||||
|
||||
emphTag :: PandocMonad m => MuseParser m (F Inlines)
|
||||
emphTag = inlineTag B.emph "em"
|
||||
|
||||
superscriptTag :: PandocMonad m => MuseParser m (F Inlines)
|
||||
superscriptTag = inlineTag B.superscript "sup"
|
||||
|
||||
subscriptTag :: PandocMonad m => MuseParser m (F Inlines)
|
||||
subscriptTag = inlineTag B.subscript "sub"
|
||||
|
||||
strikeoutTag :: PandocMonad m => MuseParser m (F Inlines)
|
||||
strikeoutTag = inlineTag B.strikeout "del"
|
||||
|
||||
code :: PandocMonad m => MuseParser m (F Inlines)
|
||||
code = return . B.code <$> verbatimBetween '='
|
||||
|
||||
codeTag :: PandocMonad m => MuseParser m (F Inlines)
|
||||
codeTag = do
|
||||
(attrs, content) <- parseHtmlContentWithAttrs "code" anyChar
|
||||
return $ return $ B.codeWith attrs $ fromEntities content
|
||||
|
||||
str :: PandocMonad m => MuseParser m (F Inlines)
|
||||
str = liftM (return . B.str) (many1 alphaNum <|> count 1 characterReference)
|
||||
|
||||
symbol :: PandocMonad m => MuseParser m (F Inlines)
|
||||
symbol = liftM (return . B.str) $ count 1 nonspaceChar
|
||||
|
||||
link :: PandocMonad m => MuseParser m (F Inlines)
|
||||
link = try $ do
|
||||
st <- getState
|
||||
guard $ stateAllowLinks st
|
||||
setState $ st{ stateAllowLinks = False }
|
||||
(url, title, content) <- linkText
|
||||
setState $ st{ stateAllowLinks = True }
|
||||
return $ case stripPrefix "URL:" url of
|
||||
Nothing -> if isImageUrl url
|
||||
then B.image url title <$> fromMaybe (return mempty) content
|
||||
else B.link url title <$> fromMaybe (return $ B.str url) content
|
||||
Just url' -> B.link url' title <$> fromMaybe (return $ B.str url') content
|
||||
where -- Taken from muse-image-regexp defined in Emacs Muse file lisp/muse-regexps.el
|
||||
imageExtensions = [".eps", ".gif", ".jpg", ".jpeg", ".pbm", ".png", ".tiff", ".xbm", ".xpm"]
|
||||
isImageUrl = (`elem` imageExtensions) . takeExtension
|
||||
|
||||
linkContent :: PandocMonad m => MuseParser m (F Inlines)
|
||||
linkContent = do
|
||||
char '['
|
||||
res <- many1Till anyChar $ char ']'
|
||||
parseFromString (mconcat <$> many1 inline) res
|
||||
|
||||
linkText :: PandocMonad m => MuseParser m (String, String, Maybe (F Inlines))
|
||||
linkText = do
|
||||
string "[["
|
||||
url <- many1Till anyChar $ char ']'
|
||||
content <- optionMaybe linkContent
|
||||
char ']'
|
||||
return (url, "", content)
|
||||
264
test/Tests/Readers/Muse.hs
Normal file
264
test/Tests/Readers/Muse.hs
Normal file
|
|
@ -0,0 +1,264 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Tests.Readers.Muse (tests) where
|
||||
|
||||
import Data.List (intersperse)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Test.Tasty
|
||||
import Tests.Helpers
|
||||
import Text.Pandoc
|
||||
import Text.Pandoc.Arbitrary ()
|
||||
import Text.Pandoc.Builder
|
||||
import Text.Pandoc.Class
|
||||
|
||||
muse :: Text -> Pandoc
|
||||
muse = purely $ \s -> do
|
||||
putCommonState
|
||||
def { stInputFiles = Just ["in"]
|
||||
, stOutputFile = Just "out"
|
||||
}
|
||||
readMuse def s
|
||||
|
||||
infix 4 =:
|
||||
(=:) :: ToString c
|
||||
=> String -> (Text, c) -> TestTree
|
||||
(=:) = test muse
|
||||
|
||||
spcSep :: [Inlines] -> Inlines
|
||||
spcSep = mconcat . intersperse space
|
||||
|
||||
tests :: [TestTree]
|
||||
tests =
|
||||
[ testGroup "Inlines"
|
||||
[ "Plain String" =:
|
||||
"Hello, World" =?>
|
||||
para (spcSep [ "Hello,", "World" ])
|
||||
|
||||
, "Emphasis" =: "*Foo bar*" =?> para (emph . spcSep $ ["Foo", "bar"])
|
||||
|
||||
, "Emphasis tag" =: "<em>Foo bar</em>" =?> para (emph . spcSep $ ["Foo", "bar"])
|
||||
|
||||
, "Strong" =:
|
||||
"**Cider**" =?>
|
||||
para (strong "Cider")
|
||||
|
||||
, "Strong tag" =: "<strong>Strong</strong>" =?> para (strong "Strong")
|
||||
|
||||
, "Strong Emphasis" =:
|
||||
"***strength***" =?>
|
||||
para (strong . emph $ "strength")
|
||||
|
||||
, "Superscript tag" =: "<sup>Superscript</sup>" =?> para (superscript "Superscript")
|
||||
|
||||
, "Subscript tag" =: "<sub>Subscript</sub>" =?> para (subscript "Subscript")
|
||||
|
||||
, "Strikeout tag" =: "<del>Strikeout</del>" =?> para (strikeout "Strikeout")
|
||||
|
||||
, "Linebreak" =: "Line <br> break" =?> para ("Line" <> linebreak <> "break")
|
||||
|
||||
, "Code" =: "=foo(bar)=" =?> para (code "foo(bar)")
|
||||
|
||||
, "Code tag" =: "<code>foo(bar)</code>" =?> para (code "foo(bar)")
|
||||
|
||||
, testGroup "Links"
|
||||
[ "Link without description" =:
|
||||
"[[https://amusewiki.org/]]" =?>
|
||||
para (link "https://amusewiki.org/" "" (str "https://amusewiki.org/"))
|
||||
, "Link with description" =:
|
||||
"[[https://amusewiki.org/][A Muse Wiki]]" =?>
|
||||
para (link "https://amusewiki.org/" "" (text "A Muse Wiki"))
|
||||
, "Image" =:
|
||||
"[[image.jpg]]" =?>
|
||||
para (image "image.jpg" "" mempty)
|
||||
, "Image with description" =:
|
||||
"[[image.jpg][Image]]" =?>
|
||||
para (image "image.jpg" "" (text "Image"))
|
||||
, "Image link" =:
|
||||
"[[URL:image.jpg]]" =?>
|
||||
para (link "image.jpg" "" (str "image.jpg"))
|
||||
, "Image link with description" =:
|
||||
"[[URL:image.jpg][Image]]" =?>
|
||||
para (link "image.jpg" "" (text "Image"))
|
||||
]
|
||||
]
|
||||
|
||||
, testGroup "Blocks"
|
||||
[ "Quote" =: "<quote>Hello, world</quote>" =?> blockQuote (para $ text "Hello, world")
|
||||
, "Center" =: "<center>Hello, world</center>" =?> para (text "Hello, world")
|
||||
, "Right" =: "<right>Hello, world</right>" =?> para (text "Hello, world")
|
||||
, testGroup "Comments"
|
||||
[ "Comment tag" =: "<comment>\nThis is a comment\n</comment>" =?> (mempty::Blocks)
|
||||
, "Line comment" =: "; Comment" =?> (mempty::Blocks)
|
||||
, "Not a comment (does not start with a semicolon)" =: " ; Not a comment" =?> para (text "; Not a comment")
|
||||
, "Not a comment (has no space after semicolon)" =: ";Not a comment" =?> para (text ";Not a comment")
|
||||
]
|
||||
, testGroup "Headers"
|
||||
[ "Part" =:
|
||||
"* First level\n" =?>
|
||||
header 1 "First level"
|
||||
, "Chapter" =:
|
||||
"** Second level\n" =?>
|
||||
header 2 "Second level"
|
||||
, "Section" =:
|
||||
"*** Third level\n" =?>
|
||||
header 3 "Third level"
|
||||
, "Subsection" =:
|
||||
"**** Fourth level\n" =?>
|
||||
header 4 "Fourth level"
|
||||
, "Subsubsection" =:
|
||||
"***** Fifth level\n" =?>
|
||||
header 5 "Fifth level"
|
||||
]
|
||||
, testGroup "Footnotes"
|
||||
[ "Simple footnote" =:
|
||||
T.unlines [ "Here is a footnote[1]."
|
||||
, ""
|
||||
, "[1] Footnote contents"
|
||||
] =?>
|
||||
para (text "Here is a footnote" <>
|
||||
note (para "Footnote contents") <>
|
||||
str ".")
|
||||
, "Recursive footnote" =:
|
||||
T.unlines [ "Start recursion here[1]"
|
||||
, ""
|
||||
, "[1] Recursion continues here[1]"
|
||||
] =?>
|
||||
para (text "Start recursion here" <>
|
||||
note (para "Recursion continues here[1]"))
|
||||
]
|
||||
]
|
||||
, testGroup "Tables"
|
||||
[ "Two cell table" =:
|
||||
"One | Two" =?>
|
||||
table mempty [(AlignDefault, 0.0), (AlignDefault, 0.0)]
|
||||
[]
|
||||
[[plain "One", plain "Two"]]
|
||||
, "Table with multiple words" =:
|
||||
"One two | three four" =?>
|
||||
table mempty [(AlignDefault, 0.0), (AlignDefault, 0.0)]
|
||||
[]
|
||||
[[plain "One two", plain "three four"]]
|
||||
, "Not a table" =:
|
||||
"One| Two" =?>
|
||||
para (text "One| Two")
|
||||
, "Not a table again" =:
|
||||
"One |Two" =?>
|
||||
para (text "One |Two")
|
||||
, "Two line table" =:
|
||||
T.unlines
|
||||
[ "One | Two"
|
||||
, "Three | Four"
|
||||
] =?>
|
||||
table mempty [(AlignDefault, 0.0), (AlignDefault, 0.0)]
|
||||
[]
|
||||
[[plain "One", plain "Two"],
|
||||
[plain "Three", plain "Four"]]
|
||||
, "Table with one header" =:
|
||||
T.unlines
|
||||
[ "First || Second"
|
||||
, "Third | Fourth"
|
||||
] =?>
|
||||
table mempty [(AlignDefault, 0.0), (AlignDefault, 0.0)]
|
||||
[plain "First", plain "Second"]
|
||||
[[plain "Third", plain "Fourth"]]
|
||||
, "Table with two headers" =:
|
||||
T.unlines
|
||||
[ "First || header"
|
||||
, "Second || header"
|
||||
, "Foo | bar"
|
||||
] =?>
|
||||
table mempty [(AlignDefault, 0.0), (AlignDefault, 0.0)]
|
||||
[plain "First", plain "header"]
|
||||
[[plain "Second", plain "header"],
|
||||
[plain "Foo", plain "bar"]]
|
||||
, "Header and footer reordering" =:
|
||||
T.unlines
|
||||
[ "Foo ||| bar"
|
||||
, "Baz || foo"
|
||||
, "Bar | baz"
|
||||
] =?>
|
||||
table mempty [(AlignDefault, 0.0), (AlignDefault, 0.0)]
|
||||
[plain "Baz", plain "foo"]
|
||||
[[plain "Bar", plain "baz"],
|
||||
[plain "Foo", plain "bar"]]
|
||||
, "Table with caption" =:
|
||||
T.unlines
|
||||
[ "Foo || bar || baz"
|
||||
, "First | row | here"
|
||||
, "Second | row | there"
|
||||
, "|+ Table caption +|"
|
||||
] =?>
|
||||
table (text "Table caption") (replicate 3 (AlignDefault, 0.0))
|
||||
[plain "Foo", plain "bar", plain "baz"]
|
||||
[[plain "First", plain "row", plain "here"],
|
||||
[plain "Second", plain "row", plain "there"]]
|
||||
, "Caption without table" =:
|
||||
"|+ Foo bar baz +|" =?>
|
||||
table (text "Foo bar baz") [] [] []
|
||||
, "Table indented with space" =:
|
||||
T.unlines
|
||||
[ " Foo | bar"
|
||||
, " Baz | foo"
|
||||
, " Bar | baz"
|
||||
] =?>
|
||||
table mempty [(AlignDefault, 0.0), (AlignDefault, 0.0)]
|
||||
[]
|
||||
[[plain "Foo", plain "bar"],
|
||||
[plain "Baz", plain "foo"],
|
||||
[plain "Bar", plain "baz"]]
|
||||
, "Empty cells" =:
|
||||
T.unlines
|
||||
[ " | Foo"
|
||||
, " |"
|
||||
, " bar |"
|
||||
, " || baz"
|
||||
] =?>
|
||||
table mempty [(AlignDefault, 0.0), (AlignDefault, 0.0)]
|
||||
[plain "", plain "baz"]
|
||||
[[plain "", plain "Foo"],
|
||||
[plain "", plain ""],
|
||||
[plain "bar", plain ""]]
|
||||
]
|
||||
, testGroup "Lists"
|
||||
[ "Bullet list" =:
|
||||
T.unlines
|
||||
[ " - Item1"
|
||||
, ""
|
||||
, " - Item2"
|
||||
] =?>
|
||||
bulletList [ para "Item1"
|
||||
, para "Item2"
|
||||
]
|
||||
, "Ordered list" =:
|
||||
T.unlines
|
||||
[ " 1. Item1"
|
||||
, ""
|
||||
, " 2. Item2"
|
||||
] =?>
|
||||
orderedListWith (1, Decimal, Period) [ para "Item1"
|
||||
, para "Item2"
|
||||
]
|
||||
, "Nested list" =:
|
||||
T.unlines
|
||||
[ " - Item1"
|
||||
, " - Item2"
|
||||
, " - Item3"
|
||||
, " - Item4"
|
||||
, " 1. Nested"
|
||||
, " 2. Ordered"
|
||||
, " 3. List"
|
||||
] =?>
|
||||
bulletList [ mconcat [ para "Item1"
|
||||
, bulletList [ para "Item2"
|
||||
, para "Item3"
|
||||
]
|
||||
]
|
||||
, mconcat [ para "Item4"
|
||||
, orderedListWith (1, Decimal, Period) [ para "Nested"
|
||||
, para "Ordered"
|
||||
, para "List"
|
||||
]
|
||||
]
|
||||
]
|
||||
]
|
||||
]
|
||||
|
|
@ -16,6 +16,7 @@ import qualified Tests.Readers.Odt
|
|||
import qualified Tests.Readers.Org
|
||||
import qualified Tests.Readers.RST
|
||||
import qualified Tests.Readers.Txt2Tags
|
||||
import qualified Tests.Readers.Muse
|
||||
import qualified Tests.Shared
|
||||
import qualified Tests.Writers.AsciiDoc
|
||||
import qualified Tests.Writers.ConTeXt
|
||||
|
|
@ -61,6 +62,7 @@ tests = testGroup "pandoc tests" [ Tests.Command.tests
|
|||
, testGroup "Odt" Tests.Readers.Odt.tests
|
||||
, testGroup "Txt2Tags" Tests.Readers.Txt2Tags.tests
|
||||
, testGroup "EPUB" Tests.Readers.EPUB.tests
|
||||
, testGroup "Muse" Tests.Readers.Muse.tests
|
||||
]
|
||||
, testGroup "Lua filters" Tests.Lua.tests
|
||||
]
|
||||
|
|
|
|||
|
|
@ -88,6 +88,7 @@ $(document).ready(function() {
|
|||
<option value="markdown_github">Markdown (GitHub)</option>
|
||||
<option value="mediawiki">MediaWiki</option>
|
||||
<option value="markdown_mmd">MultiMarkdown</option>
|
||||
<option value="muse">Muse</option>
|
||||
<option value="opml">OPML</option>
|
||||
<option value="org">Org Mode</option>
|
||||
<option value="rst">reStructuredText</option>
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue