Add Muse reader (#3620)

6 files changed, 849 insertions, 0 deletions

diff --git a/pandoc.cabal b/pandoc.cabal
index c1d76785c..a9e561fa6 100644
--- a/pandoc.cabal
+++ b/pandoc.cabal
@@ -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
diff --git a/src/Text/Pandoc/Readers.hs b/src/Text/Pandoc/Readers.hs
index 004fefe25..4c95d5d28 100644
--- a/src/Text/Pandoc/Readers.hs
+++ b/src/Text/Pandoc/Readers.hs
@@ -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).
diff --git a/src/Text/Pandoc/Readers/Muse.hs b/src/Text/Pandoc/Readers/Muse.hs
new file mode 100644
index 000000000..bc9da26cb
--- /dev/null
+++ b/src/Text/Pandoc/Readers/Muse.hs
@@ -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)
diff --git a/test/Tests/Readers/Muse.hs b/test/Tests/Readers/Muse.hs
new file mode 100644
index 000000000..5a896da55
--- /dev/null
+++ b/test/Tests/Readers/Muse.hs
@@ -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"
+                                                                     ]
+                              ]
+                    ]
+      ]
+  ]
diff --git a/test/test-pandoc.hs b/test/test-pandoc.hs
index 97ad3183f..caa2b7c65 100644
--- a/test/test-pandoc.hs
+++ b/test/test-pandoc.hs
@@ -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
         ]
diff --git a/trypandoc/index.html b/trypandoc/index.html
index 26a373112..9b84e14b7 100644
--- a/trypandoc/index.html
+++ b/trypandoc/index.html
@@ -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>