path: root/src/Text/Pandoc/Readers/Textile.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns      #-}
{- |
   Module      : Text.Pandoc.Readers.Textile
   Copyright   : Copyright (C) 2010-2012 Paul Rivier
                               2010-2024 John MacFarlane
   License     : GNU GPL, version 2 or above

   Maintainer  : Paul Rivier <paul*rivier#demotera*com>
   Stability   : alpha
   Portability : portable

Conversion from Textile to 'Pandoc' document, based on the spec
available at https://www.promptworks.com/textile/.

Implemented and parsed:
 - Paragraphs
 - Code blocks
 - Lists
 - blockquote
 - Inlines : strong, emph, cite, code, deleted, superscript,
   subscript, links
 - footnotes
 - HTML-specific and CSS-specific attributes on headers

Left to be implemented:
 - dimension sign
 - all caps
 - continued blocks (ex bq..)

TODO : refactor common patterns across readers :
 - more ...

-}


module Text.Pandoc.Readers.Textile ( readTextile) where
import Control.Monad (guard, liftM)
import Control.Monad.Except (throwError)
import Data.Char (digitToInt, isUpper)
import Data.List (intersperse, transpose, foldl')
import Data.List.NonEmpty (NonEmpty(..), nonEmpty)
import qualified Data.Map as M
import Data.Text (Text)
import qualified Data.Text as T
import Text.HTML.TagSoup (Tag (..), fromAttrib)
import Text.HTML.TagSoup.Match
import Text.Pandoc.Builder (Blocks, Inlines, trimInlines)
import qualified Text.Pandoc.Builder as B
import Text.Pandoc.Class.PandocMonad (PandocMonad (..))
import Text.Pandoc.CSS
import Text.Pandoc.Definition
import Text.Pandoc.Logging
import Text.Pandoc.Options
import Text.Pandoc.Parsing
import Text.Pandoc.Readers.HTML (htmlTag, isBlockTag, isInlineTag)
import Text.Pandoc.Readers.LaTeX (rawLaTeXBlock, rawLaTeXInline)
import Text.Pandoc.Shared (trim, tshow)
import Text.Read (readMaybe)

-- | Parse a Textile text and return a Pandoc document.
readTextile :: (PandocMonad m, ToSources a)
            => ReaderOptions -- ^ Reader options
            -> a
            -> m Pandoc
readTextile opts s = do
  let sources = ensureFinalNewlines 2 (toSources s)
  parsed <- readWithM parseTextile def{ stateOptions = opts } sources
  case parsed of
     Right result -> return result
     Left e       -> throwError e

type TextileParser = ParsecT Sources ParserState

-- | Generate a Pandoc ADT from a textile document
parseTextile :: PandocMonad m => TextileParser m Pandoc
parseTextile = do
  many blankline
  startPos <- getPosition
  -- go through once just to get list of reference keys and notes
  -- docMinusKeys is the raw document with blanks where the keys/notes were...
  let firstPassParser = do
        pos <- getPosition
        t <- noteBlock <|> referenceKey <|> lineClump
        return (pos, t)
  manyTill firstPassParser eof >>= setInput . Sources
  setPosition startPos
  st' <- getState
  let reversedNotes = stateNotes st'
  updateState $ \s -> s { stateNotes = reverse reversedNotes }
  -- now parse it for real...
  Pandoc nullMeta . B.toList <$> parseBlocks -- FIXME

noteMarker :: PandocMonad m => TextileParser m Text
noteMarker = do
  skipMany spaceChar
  string "fn"
  T.pack <$> manyTill digit (string "." <|> try (string "^."))

noteBlock :: PandocMonad m => TextileParser m Text
noteBlock = try $ do
  startPos <- getPosition
  ref <- noteMarker
  optional blankline
  contents <- T.unlines <$> many1Till anyLine (blanklines <|> noteBlock)
  endPos <- getPosition
  let newnote = (ref, contents <> "\n")
  st <- getState
  let oldnotes = stateNotes st
  updateState $ \s -> s { stateNotes = newnote : oldnotes }
  -- return blanks so line count isn't affected
  return $ T.replicate (sourceLine endPos - sourceLine startPos) "\n"

referenceKey :: PandocMonad m => TextileParser m Text
referenceKey = try $ do
  pos <- getPosition
  char '['
  refName <- T.pack <$> many1Till nonspaceChar (char ']')
  refDestination <- T.pack <$> many1Till anyChar newline
  st <- getState
  let oldKeys = stateKeys st
  let key = toKey refName
  -- Textile doesn't support link titles on the reference
  -- definition, so use the empty string
  let target = (refDestination, "")
  case M.lookup key oldKeys of
    Just (t, _) | not (t == target) ->
      -- similar to Markdown, only warn when the targets
      -- for matching named references differ
      logMessage $ DuplicateLinkReference refName pos
    _ -> return ()
  updateState $ \s -> s {stateKeys = M.insert key (target, nullAttr) oldKeys }
  return "\n"

-- | Parse document blocks
parseBlocks :: PandocMonad m => TextileParser m Blocks
parseBlocks = mconcat <$> manyTill block eof

-- | Block parsers list tried in definition order
blockParsers :: PandocMonad m => [TextileParser m Blocks]
blockParsers = [ codeBlock
               , header
               , blockQuote
               , hrule
               , commentBlock
               , anyList
               , rawHtmlBlock
               , rawLaTeXBlock'
               , table
               , explicitBlock "p" (para <|> pure (B.para mempty))
               , para
               , mempty <$ blanklines
               ]

-- | Any block in the order of definition of blockParsers
block :: PandocMonad m => TextileParser m Blocks
block = do
  res <- choice blockParsers <?> "block"
  trace (T.take 60 $ tshow $ B.toList res)
  return res

commentBlock :: PandocMonad m => TextileParser m Blocks
commentBlock = try $ do
  string "###."
  manyTill anyLine blanklines
  return mempty

codeBlock :: PandocMonad m => TextileParser m Blocks
codeBlock = codeBlockTextile <|> codeBlockHtml

codeBlockTextile :: PandocMonad m => TextileParser m Blocks
codeBlockTextile = try $ do
  string "bc." <|> string "pre."
  extended <- option False (True <$ char '.')
  char ' '
  let starts = ["p", "table", "bq", "bc", "pre", "h1", "h2", "h3",
                "h4", "h5", "h6", "pre", "###", "notextile"]
  let ender = () <$ choice (map explicitBlockStart starts)
  contents <- if extended
                 then do
                   f <- anyLine
                   rest <- many (notFollowedBy ender *> anyLine)
                   return (f:rest)
                 else manyTill anyLine blanklines
  return $ B.codeBlock (trimTrailingNewlines (T.unlines contents))

trimTrailingNewlines :: Text -> Text
trimTrailingNewlines = T.dropWhileEnd (=='\n')

-- | Code Blocks in Textile are between <pre> and </pre>
codeBlockHtml :: PandocMonad m => TextileParser m Blocks
codeBlockHtml = try $ do
  (t@(TagOpen _ attrs),_) <- htmlTag (tagOpen (=="pre") (const True))
  result' <- T.pack <$> manyTill anyChar (htmlTag (tagClose (=="pre")))
  -- drop leading newline if any
  let result'' = case T.uncons result' of
                   Just ('\n', xs) -> xs
                   _               -> result'
  -- drop trailing newline if any
  let result''' = case T.unsnoc result'' of
                    Just (xs, '\n') -> xs
                    _               -> result''
  let classes = T.words $ fromAttrib "class" t
  let ident = fromAttrib "id" t
  let kvs = [(k,v) | (k,v) <- attrs, k /= "id" && k /= "class"]
  return $ B.codeBlockWith (ident,classes,kvs) result'''

-- | Header of the form "hN. content" with N in 1..6
header :: PandocMonad m => TextileParser m Blocks
header = try $ do
  char 'h'
  level <- digitToInt <$> oneOf "123456"
  attr <- attributes
  char '.'
  lookAhead whitespace
  name <- trimInlines . mconcat <$> many inline
  attr' <- registerHeader attr name
  return $ B.headerWith attr' level name

-- | Blockquote of the form "bq. content"
blockQuote :: PandocMonad m => TextileParser m Blocks
blockQuote = try $ do
  string "bq" >> attributes >> char '.' >> whitespace
  B.blockQuote <$> para

-- Horizontal rule

hrule :: PandocMonad m => TextileParser m Blocks
hrule = try $ do
  skipSpaces
  start <- oneOf "-*"
  count 2 (skipSpaces >> char start)
  skipMany (spaceChar <|> char start)
  newline
  optional blanklines
  return B.horizontalRule

-- Lists handling

-- | Can be a bullet list or an ordered list. This implementation is
-- strict in the nesting, sublist must start at exactly "parent depth
-- plus one"
anyList :: PandocMonad m => TextileParser m Blocks
anyList = try $ anyListAtDepth 1 <* blanklines

-- | This allow one type of list to be nested into an other type,
-- provided correct nesting
anyListAtDepth :: PandocMonad m => Int -> TextileParser m Blocks
anyListAtDepth depth = choice [ bulletListAtDepth depth,
                                orderedListAtDepth depth,
                                definitionList ]

-- | Bullet List of given depth, depth being the number of leading '*'
bulletListAtDepth :: PandocMonad m => Int -> TextileParser m Blocks
bulletListAtDepth depth = try $ B.bulletList  <$> many1 (bulletListItemAtDepth depth)

-- | Bullet List Item of given depth, depth being the number of
-- leading '*'
bulletListItemAtDepth :: PandocMonad m => Int -> TextileParser m Blocks
bulletListItemAtDepth depth = try $ do
  bulletListStartAtDepth depth
  genericListItemContentsAtDepth depth

-- | Ordered List of given depth, depth being the number of
-- leading '#'
-- The first Ordered List Item may have a start attribute
orderedListAtDepth :: PandocMonad m => Int -> TextileParser m Blocks
orderedListAtDepth depth = try $ do
  (startNum, firstItem) <- firstOrderedListItemAtDepth depth
  moreItems <- many (orderedListItemAtDepth depth)
  let listItems = firstItem : moreItems
  return $ B.orderedListWith (startNum, DefaultStyle, DefaultDelim) listItems

-- | The first Ordered List Item, which could have a start attribute
firstOrderedListItemAtDepth :: PandocMonad m => Int
                                             -> TextileParser m (Int, Blocks)
firstOrderedListItemAtDepth depth = try $ do
  startNum <- orderedListStartAtDepth depth
  contents <- genericListItemContentsAtDepth depth
  return (startNum, contents)

-- | Ordered List Item of given depth, depth being the number of
-- leading '#'
orderedListItemAtDepth :: PandocMonad m => Int -> TextileParser m Blocks
orderedListItemAtDepth depth = try $ do
  orderedListStartAtDepth depth
  genericListItemContentsAtDepth depth

-- | Lists always start with a number of leading characters '#' or '*'
-- Ordered list start characters '#' can be followed by the start attribute
-- number, but bullet list characters '*' can not
orderedListStartAtDepth :: PandocMonad m => Int -> TextileParser m Int
orderedListStartAtDepth depth = count depth (char '#') >>
  try orderedListStartAttr <* (attributes >> whitespace)

bulletListStartAtDepth :: PandocMonad m => Int -> TextileParser m ()
bulletListStartAtDepth depth =  () <$ (count depth (char '*') >>
                                       attributes >> whitespace)

-- | The leading characters and start attributes differ between ordered and
-- unordered lists, but their contents have the same structure and can
-- share a Parser
genericListItemContentsAtDepth :: PandocMonad m => Int
                                                -> TextileParser m Blocks
genericListItemContentsAtDepth depth = do
  contents <- mconcat <$> many ((B.plain . mconcat <$> many1 inline) <|>
                                try (newline >> codeBlockHtml))
  newline
  sublist <- option mempty (anyListAtDepth (depth + 1))
  return $ contents <> sublist


-- | A definition list is a set of consecutive definition items
definitionList :: PandocMonad m => TextileParser m Blocks
definitionList = try $ B.definitionList <$> many1 definitionListItem

-- | List start character.
listStart :: PandocMonad m => TextileParser m ()
listStart = genericListStart '*'
        <|> () <$ orderedListStart
        <|> () <$ definitionListStart

genericListStart :: PandocMonad m => Char -> TextileParser m ()
genericListStart c = () <$ try (many1 (char c) >> whitespace)

orderedListStart :: PandocMonad m => TextileParser m ()
orderedListStart = () <$ try (many1 (char '#') >>
                              try orderedListStartAttr >>
                              whitespace)

basicDLStart :: PandocMonad m => TextileParser m ()
basicDLStart = do
  char '-'
  whitespace
  notFollowedBy newline

definitionListStart :: PandocMonad m => TextileParser m Inlines
definitionListStart = try $ do
  basicDLStart
  trimInlines . mconcat <$>
    many1Till inline
     (  try (newline *> lookAhead basicDLStart)
    <|> try (lookAhead (() <$ string ":="))
     )

-- | A definition list item in textile begins with '- ', followed by
-- the term defined, then spaces and ":=". The definition follows, on
-- the same single line, or spaned on multiple line, after a line
-- break.
definitionListItem :: PandocMonad m => TextileParser m (Inlines, [Blocks])
definitionListItem = try $ do
  term <- mconcat . intersperse B.linebreak <$> many1 definitionListStart
  def' <- string ":=" *> optional whitespace *> (multilineDef <|> inlineDef)
  return (term, def')
  where inlineDef :: PandocMonad m => TextileParser m [Blocks]
        inlineDef = liftM (\d -> [B.plain d])
                    $ optional whitespace >> (trimInlines . mconcat <$> many inline) <* newline
        multilineDef :: PandocMonad m => TextileParser m [Blocks]
        multilineDef = try $ do
          optional whitespace >> newline
          s <- T.pack <$> many1Till anyChar (try (string "=:" >> newline))
          -- this <> "\n\n" does not look very good
          ds <- parseFromString' parseBlocks (s <> "\n\n")
          return [ds]

-- raw content

-- | A raw Html Block, optionally followed by blanklines
rawHtmlBlock :: PandocMonad m => TextileParser m Blocks
rawHtmlBlock = try $ do
  skipMany spaceChar
  (_,b) <- htmlTag isBlockTag
  optional blanklines
  return $ B.rawBlock "html" b

-- | Raw block of LaTeX content
rawLaTeXBlock' :: PandocMonad m => TextileParser m Blocks
rawLaTeXBlock' = do
  guardEnabled Ext_raw_tex
  B.rawBlock "latex" <$> (rawLaTeXBlock <* spaces)


-- | In textile, paragraphs are separated by blank lines.
para :: PandocMonad m => TextileParser m Blocks
para = B.para . trimInlines . mconcat <$> many1 inline

-- Tables

toAlignment :: Char -> Alignment
toAlignment '<' = AlignLeft
toAlignment '>' = AlignRight
toAlignment '=' = AlignCenter
toAlignment _   = AlignDefault

cellAttributes :: PandocMonad m => TextileParser m (Bool, Alignment)
cellAttributes = try $ do
  isHeader <- option False (True <$ char '_')
  -- we just ignore colspan and rowspan markers:
  optional $ try $ oneOf "/\\" >> many1 digit
  -- we pay attention to alignments:
  alignment <- option AlignDefault $ toAlignment <$> oneOf "<>="
  -- ignore other attributes for now:
  _ <- attributes
  char '.'
  return (isHeader, alignment)

-- | A table cell spans until a pipe |
tableCell :: PandocMonad m => TextileParser m ((Bool, Alignment), Blocks)
tableCell = try $ do
  char '|'
  (isHeader, alignment) <- option (False, AlignDefault) cellAttributes
  notFollowedBy blankline
  raw <- trim . T.pack <$>
         many (noneOf "|\n" <|> try (char '\n' <* notFollowedBy blankline))
  content <- mconcat <$> parseFromString' (many inline) raw
  return ((isHeader, alignment), B.plain content)

-- | A table row is made of many table cells
tableRow :: PandocMonad m => TextileParser m [((Bool, Alignment), Blocks)]
tableRow = try $ do
  -- skip optional row attributes
  optional $ try $ do
    _ <- attributes
    char '.'
    many1 spaceChar
  many1 tableCell <* char '|' <* blankline

-- | A table with an optional header.
table :: PandocMonad m => TextileParser m Blocks
table = try $ do
  -- ignore table attributes
  caption <- option mempty $ try $ do
    string "table"
    _ <- attributes
    char '.'
    rawcapt <- trim <$> anyLine
    parseFromString' (mconcat <$> many inline) rawcapt
  rawrows <- many1 $ skipMany ignorableRow >> tableRow
  skipMany ignorableRow
  blanklines
  let (headers, rows) = case rawrows of
                             (toprow:rest) | any (fst . fst) toprow ->
                                (toprow, rest)
                             _ -> (mempty, rawrows)
  let nbOfCols = maximum $ fmap length (headers :| rows)
  let aligns = map (maybe AlignDefault minimum . nonEmpty) $
                transpose $ map (map (snd . fst)) (headers:rows)
  let toRow = Row nullAttr . map B.simpleCell
      toHeaderRow l = [toRow l | not (null l)]
  return $ B.table (B.simpleCaption $ B.plain caption)
    (zip aligns (replicate nbOfCols ColWidthDefault))
    (TableHead nullAttr $ toHeaderRow $ map snd headers)
    [TableBody nullAttr 0 [] $ map (toRow . map snd) rows]
    (TableFoot nullAttr [])

-- | Ignore markers for cols, thead, tfoot.
ignorableRow :: PandocMonad m => TextileParser m ()
ignorableRow = try $ do
  char '|'
  oneOf ":^-~"
  _ <- attributes
  char '.'
  _ <- anyLine
  return ()

explicitBlockStart :: PandocMonad m => Text -> TextileParser m Attr
explicitBlockStart name = try $ do
  string (T.unpack name)
  attr <- attributes
  char '.'
  optional whitespace
  optional endline
  return attr

-- | Blocks like 'p' and 'table' do not need explicit block tag.
-- However, they can be used to set HTML/CSS attributes when needed.
explicitBlock :: PandocMonad m
              => Text  -- ^ block tag name
              -> TextileParser m Blocks -- ^ implicit block
              -> TextileParser m Blocks
explicitBlock name blk = try $ do
  attr <- explicitBlockStart name
  contents <- blk
  return $ if attr == nullAttr
              then contents
              else B.divWith attr contents

----------
-- Inlines
----------


-- | Any inline element
inline :: PandocMonad m => TextileParser m Inlines
inline = choice inlineParsers <?> "inline"

-- | Inline parsers tried in order
inlineParsers :: PandocMonad m => [TextileParser m Inlines]
inlineParsers = [ str
                , whitespace
                , endline
                , code
                , escapedInline
                , spanGroup
                , inlineMarkup
                , groupedInlineMarkup
                , rawHtmlInline
                , rawLaTeXInline'
                , note
                , link
                , image
                , mark
                , B.str <$> characterReference
                , smartPunctuation inline
                , symbol
                ]

-- | Inline markups
inlineMarkup :: PandocMonad m => TextileParser m Inlines
inlineMarkup = choice [ simpleInline (string "??") (B.cite [])
                      , simpleInline (string "**") B.strong
                      , simpleInline (string "__") B.emph
                      , simpleInline (char '*') B.strong
                      , simpleInline (char '_') B.emph
                      , simpleInline (char '+') B.underline
                      , simpleInline (char '-' <* notFollowedBy (char '-')) B.strikeout
                      , simpleInline (char '^') B.superscript
                      , simpleInline (char '~') B.subscript
                      ]

-- "The <span> tag is created by percent % signs between whitespaces."
-- e.g. My mother has %{color:green;}green% eyes.
spanGroup :: PandocMonad m => TextileParser m Inlines
spanGroup = try $ do
  notAfterString >>= guard
  char '%' *> notFollowedBy whitespace
  attr <- option nullAttr attributes
  contents <- mconcat <$> manyTill
   (try (((B.space <>) <$> try (whitespace *> notFollowedBy newline *> inline))
         <|> try (notFollowedBy newline *> inline)))
   (try (char '%' <* lookAhead (newline <|> ' ' <$ whitespace)))
  pure $ B.spanWith attr contents

-- | Trademark, registered, copyright
mark :: PandocMonad m => TextileParser m Inlines
mark = try $ char '(' >> (try tm <|> try reg <|> copy)

reg :: PandocMonad m => TextileParser m Inlines
reg = do
  oneOf "Rr"
  char ')'
  return $ B.str "\174"

tm :: PandocMonad m => TextileParser m Inlines
tm = do
  oneOf "Tt"
  oneOf "Mm"
  char ')'
  return $ B.str "\8482"

copy :: PandocMonad m => TextileParser m Inlines
copy = do
  oneOf "Cc"
  char ')'
  return $ B.str "\169"

note :: PandocMonad m => TextileParser m Inlines
note = try $ do
  ref <- char '[' *> many1 digit <* char ']'
  notes <- stateNotes <$> getState
  case lookup (T.pack ref) notes of
    Nothing  -> Prelude.fail "note not found"
    Just raw -> B.note <$> parseFromString' parseBlocks raw

-- | Special chars
markupChars :: [Char]
markupChars = "\\*#_@~-+^|%=[]&"

-- | Break strings on following chars. Space tab and newline break for
--  inlines breaking. Open paren breaks for mark. Quote, dash and dot
--  break for smart punctuation. Punctuation breaks for regular
--  punctuation. Double quote breaks for named links. > and < break
--  for inline html.
stringBreakers :: [Char]
stringBreakers = " \t\n\r.,\"'?!;:<>«»„“”‚‘’()[]"

wordBoundaries :: [Char]
wordBoundaries = markupChars <> stringBreakers

-- | Parse a hyphened sequence of words
hyphenedWords :: PandocMonad m => TextileParser m Text
hyphenedWords = do
  x <- wordChunk
  xs <-  many (try $ char '-' >> wordChunk)
  return $ T.intercalate "-" (x:xs)

wordChunk :: PandocMonad m => TextileParser m Text
wordChunk = try $ do
  hd <- noneOf wordBoundaries
  tl <- many ( noneOf wordBoundaries <|>
               try (notFollowedBy' note *> oneOf markupChars
                     <* lookAhead (noneOf wordBoundaries) ) )
  return $ T.pack $ hd:tl

-- | Any string
str :: PandocMonad m => TextileParser m Inlines
str = do
  baseStr <- hyphenedWords
  -- RedCloth compliance : if parsed word is uppercase and immediately
  -- followed by parens, parens content is unconditionally word acronym
  fullStr <- option baseStr $ try $ do
    guard $ T.all isUpper baseStr
    acro <- T.pack <$> enclosed (char '(') (char ')') anyChar'
    return $ T.concat [baseStr, " (", acro, ")"]
  updateLastStrPos
  return $ B.str fullStr

-- | Some number of space chars
whitespace :: PandocMonad m => TextileParser m Inlines
whitespace = many1 spaceChar >> return B.space <?> "whitespace"

-- | In Textile, an isolated endline character is a line break
endline :: PandocMonad m => TextileParser m Inlines
endline = try $ do
  newline
  notFollowedBy blankline
  notFollowedBy listStart
  notFollowedBy rawHtmlBlock
  return B.linebreak

rawHtmlInline :: PandocMonad m => TextileParser m Inlines
rawHtmlInline = B.rawInline "html" . snd <$> htmlTag isInlineTag

-- | Raw LaTeX Inline
rawLaTeXInline' :: PandocMonad m => TextileParser m Inlines
rawLaTeXInline' = try $ do
  guardEnabled Ext_raw_tex
  B.rawInline "latex" <$> rawLaTeXInline

-- | Textile standard link syntax is "label":target. But we
-- can also have ["label":target].
link :: PandocMonad m => TextileParser m Inlines
link = try $ do
  bracketed <- (True <$ char '[') <|> return False
  char '"' *> notFollowedBy (oneOf " \t\n\r")
  attr <- attributes
  name <- trimInlines . mconcat <$>
          withQuoteContext InDoubleQuote (many1Till inline (char '"'))
  url <- linkUrl bracketed
  let name' = if B.toList name == [Str "$"] then B.str url else name
  return $ if attr == nullAttr
              then B.link url "" name'
              else B.spanWith attr $ B.link url "" name'

linkUrl :: PandocMonad m => Bool -> TextileParser m Text
linkUrl bracketed = do
  char ':'
  let stop = if bracketed
                then char ']'
                else lookAhead $ space <|> eof' <|> oneOf "[]" <|>
                       try (oneOf "!.,;:*" *>
                              (space <|> newline <|> eof'))
  rawLink <- T.pack <$> many1Till nonspaceChar stop
  st <- getState
  return $ case M.lookup (toKey rawLink) (stateKeys st) of
    Nothing -> rawLink
    Just ((src, _), _) -> src

-- | image embedding
image :: PandocMonad m => TextileParser m Inlines
image = try $ do
  char '!' >> notFollowedBy space
  (ident, cls, kvs) <- attributes
  let attr = case lookup "style" kvs of
               Just stls -> (ident, cls, pickStylesToKVs ["width", "height"] stls)
               Nothing   -> (ident, cls, kvs)
  src <- T.pack <$> many1 (noneOf " \t\n\r!(")
  alt <- fmap T.pack $ option "" $ try $ char '(' *> manyTill anyChar (char ')')
  char '!'
  let img = B.imageWith attr src alt (B.str alt)
  try (do -- image link
         url <- linkUrl False
         return (B.link url "" img))
   <|> return img

escapedInline :: PandocMonad m => TextileParser m Inlines
escapedInline = escapedEqs <|> escapedTag

escapedEqs :: PandocMonad m => TextileParser m Inlines
escapedEqs = B.str . T.pack <$>
  try (string "==" *> manyTill anyChar' (try $ string "=="))

-- | literal text escaped btw <notextile> tags
escapedTag :: PandocMonad m => TextileParser m Inlines
escapedTag = B.str . T.pack <$>
  try (string "<notextile>" *>
         manyTill anyChar' (try $ string "</notextile>"))

-- | Any special symbol defined in wordBoundaries
symbol :: PandocMonad m => TextileParser m Inlines
symbol = do
  c <- notFollowedBy newline *>
         notFollowedBy rawHtmlBlock *>
         oneOf wordBoundaries
  updateLastStrPos
  pure $ B.str . T.singleton $ c

-- | Inline code
code :: PandocMonad m => TextileParser m Inlines
code = code1 <|> code2

-- any character except a newline before a blank line
anyChar' :: PandocMonad m => TextileParser m Char
anyChar' =
  satisfy (/='\n') <|>
  try (char '\n' <* notFollowedBy blankline)

code1 :: PandocMonad m => TextileParser m Inlines
code1 = B.code . T.pack <$> surrounded (char '@') anyChar'

code2 :: PandocMonad m => TextileParser m Inlines
code2 = do
  htmlTag (tagOpen (=="tt") null)
  B.code . T.pack <$> manyTill anyChar' (try $ htmlTag $ tagClose (=="tt"))

orderedListStartAttr :: PandocMonad m => TextileParser m Int
orderedListStartAttr = do
  digits <- many digit
  case readMaybe digits :: Maybe Int of
    Nothing -> return 1
    Just n  -> return n

-- | Html / CSS attributes
attributes :: PandocMonad m => TextileParser m Attr
attributes = foldl' (flip ($)) ("",[],[]) <$>
  try (do special <- option id specialAttribute
          attrs <- many attribute
          return (special : attrs))

specialAttribute :: PandocMonad m => TextileParser m (Attr -> Attr)
specialAttribute = do
  alignStr <- ("center" <$ char '=') <|>
    ("justify" <$ try (string "<>")) <|>
    ("right" <$ char '>') <|>
    ("left" <$ char '<')
  notFollowedBy spaceChar
  return $ addStyle $ T.pack $ "text-align:" ++ alignStr

attribute :: PandocMonad m => TextileParser m (Attr -> Attr)
attribute = try $
  (classIdAttr <|> styleAttr <|> langAttr) <* notFollowedBy spaceChar

classIdAttr :: PandocMonad m => TextileParser m (Attr -> Attr)
classIdAttr = try $ do -- (class class #id)
  char '('
  ws <- T.words `fmap` T.pack <$> manyTill anyChar' (char ')')
  case reverse ws of
       []
         -> return $ \(_,_,keyvals) -> ("",[],keyvals)
       ((T.uncons -> Just ('#', ident')):classes')
         -> return $ \(_,_,keyvals) -> (ident',classes',keyvals)
       classes'
         -> return $ \(_,_,keyvals) -> ("",classes',keyvals)

styleAttr :: PandocMonad m => TextileParser m (Attr -> Attr)
styleAttr = do
  style <- try $ enclosed (char '{') (char '}') anyChar'
  return $ addStyle $ T.pack style

addStyle :: Text -> Attr -> Attr
addStyle style (id',classes,keyvals) =
  (id',classes,keyvals')
  where keyvals' = ("style", style') : [(k,v) | (k,v) <- keyvals, k /= "style"]
        style' = style <> ";" <> T.concat [v | ("style",v) <- keyvals]

langAttr :: PandocMonad m => TextileParser m (Attr -> Attr)
langAttr = do
  lang <- try $ enclosed (char '[') (char ']') alphaNum
  return $ \(id',classes,keyvals) -> (id',classes,("lang",T.pack lang):keyvals)

-- | Parses material surrounded by a parser.
surrounded :: (PandocMonad m, Show t)
           => ParsecT Sources st m t   -- ^ surrounding parser
           -> ParsecT Sources st m a   -- ^ content parser (to be used repeatedly)
           -> ParsecT Sources st m [a]
surrounded border =
  enclosed (border *> notFollowedBy (oneOf " \t\n\r")) (try border)

simpleInline :: PandocMonad m
             => TextileParser m t        -- ^ surrounding parser
             -> (Inlines -> Inlines)                  -- ^ Inline constructor
             -> TextileParser m Inlines  -- ^ content parser (to be used repeatedly)
simpleInline border construct = try $ do
  notAfterString >>= guard
  border *> notFollowedBy (oneOf " \t\n\r")
  attr <- attributes
  body <- trimInlines . mconcat <$>
          withQuoteContext InSingleQuote
            (manyTill (((B.space <>) <$>
                         try (whitespace *> notFollowedBy newline >> inline))
                     <|> try (notFollowedBy newline >> inline))
             (try border <* notFollowedBy alphaNum))
  return $ construct $
        if attr == nullAttr
           then body
           else B.spanWith attr body

groupedInlineMarkup :: PandocMonad m => TextileParser m Inlines
groupedInlineMarkup = try $ do
    char '['
    sp1 <- option mempty $ B.space <$ whitespace
    result <- withQuoteContext InSingleQuote inlineMarkup
    sp2 <- option mempty $ B.space <$ whitespace
    char ']'
    return $ sp1 <> result <> sp2

eof' :: Monad m => ParsecT Sources s m Char
eof' = '\n' <$ eof