path: root/src/Text/Pandoc/Readers/Org/Blocks.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-
Copyright (C) 2014-2017 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>

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.Org.Options
   Copyright   : Copyright (C) 2014-2017 Albert Krewinkel
   License     : GNU GPL, version 2 or above

   Maintainer  : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>

Parsers for Org-mode block elements.
-}
module Text.Pandoc.Readers.Org.Blocks
  ( blockList
  , meta
  ) where

import           Text.Pandoc.Readers.Org.BlockStarts
import           Text.Pandoc.Readers.Org.Inlines
import           Text.Pandoc.Readers.Org.Meta ( metaExport, metaKey, metaLine )
import           Text.Pandoc.Readers.Org.ParserState
import           Text.Pandoc.Readers.Org.Parsing
import           Text.Pandoc.Readers.Org.Shared
                   ( cleanLinkString, isImageFilename, rundocBlockClass
                   , toRundocAttrib, translateLang )

import qualified Text.Pandoc.Builder as B
import           Text.Pandoc.Builder ( Inlines, Blocks )
import           Text.Pandoc.Definition
import           Text.Pandoc.Options
import           Text.Pandoc.Shared ( compactify', compactify'DL, safeRead )

import           Control.Monad ( foldM, guard, mzero, void )
import           Data.Char ( isSpace, toLower, toUpper)
import           Data.Default ( Default )
import           Data.List ( foldl', isPrefixOf )
import           Data.Maybe ( fromMaybe, isNothing )
import           Data.Monoid ((<>))

--
-- Org headers
--
newtype Tag = Tag { fromTag :: String }
  deriving (Show, Eq)

-- | Create a tag containing the given string.
toTag :: String -> Tag
toTag = Tag

-- | The key (also called name or type) of a property.
newtype PropertyKey = PropertyKey { fromKey :: String }
  deriving (Show, Eq, Ord)

-- | Create a property key containing the given string.  Org mode keys are
-- case insensitive and are hence converted to lower case.
toPropertyKey :: String -> PropertyKey
toPropertyKey = PropertyKey . map toLower

-- | The value assigned to a property.
newtype PropertyValue = PropertyValue { fromValue :: String }

-- | Create a property value containing the given string.
toPropertyValue :: String -> PropertyValue
toPropertyValue = PropertyValue

-- | Check whether the property value is non-nil (i.e. truish).
isNonNil :: PropertyValue -> Bool
isNonNil p = map toLower (fromValue p) `notElem` ["()", "{}", "nil"]

-- | Key/value pairs from a PROPERTIES drawer
type Properties = [(PropertyKey, PropertyValue)]

-- | Org mode headline (i.e. a document subtree).
data Headline = Headline
  { headlineLevel      :: Int
  , headlineTodoMarker :: Maybe TodoMarker
  , headlineText       :: Inlines
  , headlineTags       :: [Tag]
  , headlineProperties :: Properties
  , headlineContents   :: Blocks
  , headlineChildren   :: [Headline]
  }

--
-- Parsing headlines and subtrees
--

-- | Read an Org mode headline and its contents (i.e. a document subtree).
-- @lvl@ gives the minimum acceptable level of the tree.
headline :: Int -> OrgParser (F Headline)
headline lvl = try $ do
  level <- headerStart
  guard (lvl <= level)
  todoKw <- optionMaybe todoKeyword
  title <- trimInlinesF . mconcat <$> manyTill inline endOfTitle
  tags  <- option [] headerTags
  newline
  properties <- option mempty propertiesDrawer
  contents   <- blocks
  children   <- many (headline (level + 1))
  return $ do
    title'    <- title
    contents' <- contents
    children' <- sequence children
    return $ Headline
      { headlineLevel = level
      , headlineTodoMarker = todoKw
      , headlineText = title'
      , headlineTags = tags
      , headlineProperties = properties
      , headlineContents = contents'
      , headlineChildren = children'
      }
 where
   endOfTitle :: OrgParser ()
   endOfTitle = void . lookAhead $ optional headerTags *> newline

   headerTags :: OrgParser [Tag]
   headerTags = try $
     let tag = many1 (alphaNum <|> oneOf "@%#_") <* char ':'
     in map toTag <$> (skipSpaces *> char ':' *> many1 tag <* skipSpaces)

-- | Convert an Org mode headline (i.e. a document tree) into pandoc's Blocks
headlineToBlocks :: Headline -> OrgParser Blocks
headlineToBlocks hdln@(Headline {..}) = do
  maxHeadlineLevels <- getExportSetting exportHeadlineLevels
  case () of
    _ | any isNoExportTag headlineTags     -> return mempty
    _ | any isArchiveTag  headlineTags     -> archivedHeadlineToBlocks hdln
    _ | isCommentTitle headlineText        -> return mempty
    _ | headlineLevel >= maxHeadlineLevels -> headlineToHeaderWithList hdln
    _ | otherwise                          -> headlineToHeaderWithContents hdln

isNoExportTag :: Tag -> Bool
isNoExportTag = (== toTag "noexport")

isArchiveTag :: Tag -> Bool
isArchiveTag = (== toTag "ARCHIVE")

-- | Check if the title starts with COMMENT.
-- FIXME: This accesses builder internals not intended for use in situations
-- like these.  Replace once keyword parsing is supported.
isCommentTitle :: Inlines -> Bool
isCommentTitle (B.toList -> (Str "COMMENT":_)) = True
isCommentTitle _                               = False

archivedHeadlineToBlocks :: Headline -> OrgParser Blocks
archivedHeadlineToBlocks hdln = do
  archivedTreesOption <- getExportSetting exportArchivedTrees
  case archivedTreesOption of
    ArchivedTreesNoExport     -> return mempty
    ArchivedTreesExport       -> headlineToHeaderWithContents hdln
    ArchivedTreesHeadlineOnly -> headlineToHeader hdln

headlineToHeaderWithList :: Headline -> OrgParser Blocks
headlineToHeaderWithList hdln@(Headline {..}) = do
  maxHeadlineLevels <- getExportSetting exportHeadlineLevels
  header        <- headlineToHeader hdln
  listElements  <- sequence (map headlineToBlocks headlineChildren)
  let listBlock  = if null listElements
                   then mempty
                   else B.orderedList listElements
  let headerText = if maxHeadlineLevels == headlineLevel
                   then header
                   else flattenHeader header
  return $ headerText <> headlineContents <> listBlock
 where
   flattenHeader :: Blocks -> Blocks
   flattenHeader blks =
     case B.toList blks of
       (Header _ _ inlns:_) -> B.para (B.fromList inlns)
       _                    -> mempty

headlineToHeaderWithContents :: Headline -> OrgParser Blocks
headlineToHeaderWithContents hdln@(Headline {..}) = do
  header         <- headlineToHeader hdln
  childrenBlocks <- mconcat <$> sequence (map headlineToBlocks headlineChildren)
  return $ header <> headlineContents <> childrenBlocks

headlineToHeader :: Headline -> OrgParser Blocks
headlineToHeader (Headline {..}) = do
  exportTodoKeyword <- getExportSetting exportWithTodoKeywords
  let todoText    = if exportTodoKeyword
                    then case headlineTodoMarker of
                      Just kw -> todoKeywordToInlines kw <> B.space
                      Nothing -> mempty
                    else mempty
  let text        = tagTitle (todoText <> headlineText) headlineTags
  let propAttr    = propertiesToAttr headlineProperties
  attr           <- registerHeader propAttr headlineText
  return $ B.headerWith attr headlineLevel text

todoKeyword :: OrgParser TodoMarker
todoKeyword = try $ do
  taskStates <- activeTodoMarkers <$> getState
  let kwParser tdm = try $ (tdm <$ string (todoMarkerName tdm) <* spaceChar)
  choice (map kwParser taskStates)

todoKeywordToInlines :: TodoMarker -> Inlines
todoKeywordToInlines tdm =
  let todoText  = todoMarkerName tdm
      todoState = map toLower . show $ todoMarkerState tdm
      classes = [todoState, todoText]
  in B.spanWith (mempty, classes, mempty) (B.str todoText)

propertiesToAttr :: Properties -> Attr
propertiesToAttr properties =
  let
    toStringPair prop = (fromKey (fst prop), fromValue (snd prop))
    customIdKey = toPropertyKey "custom_id"
    classKey    = toPropertyKey "class"
    unnumberedKey = toPropertyKey "unnumbered"
    specialProperties = [customIdKey, classKey, unnumberedKey]
    id'  = fromMaybe mempty . fmap fromValue . lookup customIdKey $ properties
    cls  = fromMaybe mempty . fmap fromValue . lookup classKey    $ properties
    kvs' = map toStringPair . filter ((`notElem` specialProperties) . fst)
           $ properties
    isUnnumbered =
      fromMaybe False . fmap isNonNil . lookup unnumberedKey $ properties
  in
    (id', words cls ++ (if isUnnumbered then ["unnumbered"] else []), kvs')

tagTitle :: Inlines -> [Tag] -> Inlines
tagTitle title tags = title <> (mconcat $ map tagToInline tags)

tagToInline :: Tag -> Inlines
tagToInline t = B.spanWith ("", ["tag"], [("data-tag-name", fromTag t)]) mempty


--
-- parsing blocks
--

-- | Get a list of blocks.
blockList :: OrgParser [Block]
blockList = do
  initialBlocks  <- blocks
  headlines      <- sequence <$> manyTill (headline 1) eof
  st             <- getState
  headlineBlocks <- fmap mconcat . sequence . map headlineToBlocks $ runF headlines st
  return . B.toList $ (runF initialBlocks st) <> headlineBlocks

-- | Get the meta information safed in the state.
meta :: OrgParser Meta
meta = do
  meta' <- metaExport
  runF meta' <$> getState

blocks :: OrgParser (F Blocks)
blocks = mconcat <$> manyTill block (void (lookAhead headerStart) <|> eof)

block :: OrgParser (F Blocks)
block = choice [ mempty <$ blanklines
               , table
               , orgBlock
               , figure
               , example
               , genericDrawer
               , specialLine
               , horizontalRule
               , list
               , latexFragment
               , noteBlock
               , paraOrPlain
               ] <?> "block"


--
-- Block Attributes
--

-- | Attributes that may be added to figures (like a name or caption).
data BlockAttributes = BlockAttributes
  { blockAttrName      :: Maybe String
  , blockAttrLabel     :: Maybe String
  , blockAttrCaption   :: Maybe (F Inlines)
  , blockAttrKeyValues :: [(String, String)]
  }

-- | Convert BlockAttributes into pandoc Attr
attrFromBlockAttributes :: BlockAttributes -> Attr
attrFromBlockAttributes (BlockAttributes{..}) =
  let
    ident   = fromMaybe mempty $ lookup "id" blockAttrKeyValues
    classes = case lookup "class" blockAttrKeyValues of
                Nothing     -> []
                Just clsStr -> words clsStr
    kv      = filter ((`notElem` ["id", "class"]) . fst) blockAttrKeyValues
  in (ident, classes, kv)

stringyMetaAttribute :: (String -> Bool) -> OrgParser (String, String)
stringyMetaAttribute attrCheck = try $ do
  metaLineStart
  attrName <- map toUpper <$> many1Till nonspaceChar (char ':')
  guard $ attrCheck attrName
  skipSpaces
  attrValue <- anyLine
  return (attrName, attrValue)

blockAttributes :: OrgParser BlockAttributes
blockAttributes = try $ do
  kv <- many (stringyMetaAttribute attrCheck)
  let caption = foldl' (appendValues "CAPTION") Nothing kv
  let kvAttrs = foldl' (appendValues "ATTR_HTML") Nothing kv
  let name    = lookup "NAME" kv
  let label   = lookup "LABEL" kv
  caption' <- case caption of
                   Nothing -> return Nothing
                   Just s  -> Just <$> parseFromString inlines (s ++ "\n")
  kvAttrs' <- parseFromString keyValues . (++ "\n") $ fromMaybe mempty kvAttrs
  return $ BlockAttributes
           { blockAttrName = name
           , blockAttrLabel = label
           , blockAttrCaption = caption'
           , blockAttrKeyValues = kvAttrs'
           }
 where
   attrCheck :: String -> Bool
   attrCheck attr =
     case attr of
       "NAME"      -> True
       "LABEL"     -> True
       "CAPTION"   -> True
       "ATTR_HTML" -> True
       _           -> False

   appendValues :: String -> Maybe String -> (String, String) -> Maybe String
   appendValues attrName accValue (key, value) =
     if key /= attrName
     then accValue
     else case accValue of
            Just acc -> Just $ acc ++ ' ':value
            Nothing  -> Just value

keyValues :: OrgParser [(String, String)]
keyValues = try $
  manyTill ((,) <$> key <*> value) newline
 where
   key :: OrgParser String
   key = try $ skipSpaces *> char ':' *> many1 nonspaceChar

   value :: OrgParser String
   value = skipSpaces *> manyTill anyChar endOfValue

   endOfValue :: OrgParser ()
   endOfValue =
     lookAhead $ (() <$ try (many1 spaceChar <* key))
              <|> () <$ newline


--
-- Org Blocks (#+BEGIN_... / #+END_...)
--

-- | Read an org-mode block delimited by #+BEGIN_TYPE and #+END_TYPE.
orgBlock :: OrgParser (F Blocks)
orgBlock = try $ do
  blockAttrs <- blockAttributes
  blkType <- blockHeaderStart
  ($ blkType) $
    case (map toLower blkType) of
      "export"  -> exportBlock
      "comment" -> rawBlockLines (const mempty)
      "html"    -> rawBlockLines (return . B.rawBlock (lowercase blkType))
      "latex"   -> rawBlockLines (return . B.rawBlock (lowercase blkType))
      "ascii"   -> rawBlockLines (return . B.rawBlock (lowercase blkType))
      "example" -> rawBlockLines (return . exampleCode)
      "quote"   -> parseBlockLines (fmap B.blockQuote)
      "verse"   -> verseBlock
      "src"     -> codeBlock blockAttrs
      _         -> parseBlockLines $
                   let (ident, classes, kv) = attrFromBlockAttributes blockAttrs
                   in fmap $ B.divWith (ident, classes ++ [blkType], kv)
 where
   blockHeaderStart :: OrgParser String
   blockHeaderStart = try $ skipSpaces *> stringAnyCase "#+begin_" *> orgArgWord

   lowercase :: String -> String
   lowercase = map toLower

rawBlockLines :: (String   -> F Blocks) -> String -> OrgParser (F Blocks)
rawBlockLines f blockType = (ignHeaders *> (f <$> rawBlockContent blockType))

parseBlockLines :: (F Blocks -> F Blocks) -> String -> OrgParser (F Blocks)
parseBlockLines f blockType = (ignHeaders *> (f <$> parsedBlockContent))
 where
   parsedBlockContent :: OrgParser (F Blocks)
   parsedBlockContent = try $ do
     raw <- rawBlockContent blockType
     parseFromString blocks (raw ++ "\n")

-- | Read the raw string content of a block
rawBlockContent :: String -> OrgParser String
rawBlockContent blockType = try $ do
  blkLines <- manyTill rawLine blockEnder
  tabLen <- getOption readerTabStop
  return
    . unlines
    . stripIndent
    . map (tabsToSpaces tabLen . commaEscaped)
    $ blkLines
 where
   rawLine :: OrgParser String
   rawLine = try $ ("" <$ blankline) <|> anyLine

   blockEnder :: OrgParser ()
   blockEnder = try $ skipSpaces <* stringAnyCase ("#+end_" <> blockType)

   stripIndent :: [String] -> [String]
   stripIndent strs = map (drop (shortestIndent strs)) strs

   shortestIndent :: [String] -> Int
   shortestIndent = foldr min maxBound
                    . map (length . takeWhile isSpace)
                    . filter (not . null)

   tabsToSpaces :: Int -> String -> String
   tabsToSpaces _      []         = []
   tabsToSpaces tabLen cs'@(c:cs) =
       case c of
         ' '  -> ' ':tabsToSpaces tabLen cs
         '\t' -> (take tabLen $ repeat ' ') ++ tabsToSpaces tabLen cs
         _    -> cs'

   commaEscaped :: String -> String
   commaEscaped (',':cs@('*':_))     = cs
   commaEscaped (',':cs@('#':'+':_)) = cs
   commaEscaped (' ':cs)             = ' ':commaEscaped cs
   commaEscaped ('\t':cs)            = '\t':commaEscaped cs
   commaEscaped cs                   = cs

-- | Read but ignore all remaining block headers.
ignHeaders :: OrgParser ()
ignHeaders = (() <$ newline) <|> (() <$ anyLine)

-- | Read a block containing code intended for export in specific backends
-- only.
exportBlock :: String -> OrgParser (F Blocks)
exportBlock blockType = try $ do
  exportType <- skipSpaces *> orgArgWord <* ignHeaders
  contents   <- rawBlockContent blockType
  returnF (B.rawBlock (map toLower exportType) contents)

verseBlock :: String -> OrgParser (F Blocks)
verseBlock blockType = try $ do
  ignHeaders
  content <- rawBlockContent blockType
  fmap B.lineBlock . sequence
    <$> mapM parseVerseLine (lines content)
 where
   -- replace initial spaces with nonbreaking spaces to preserve
   -- indentation, parse the rest as normal inline
   parseVerseLine :: String -> OrgParser (F Inlines)
   parseVerseLine cs = do
     let (initialSpaces, indentedLine) = span isSpace cs
     let nbspIndent = if null initialSpaces
                      then mempty
                      else B.str $ map (const '\160') initialSpaces
     line <- parseFromString inlines (indentedLine ++ "\n")
     return (trimInlinesF $ pure nbspIndent <> line)

-- | Read a code block and the associated results block if present.  Which of
-- boths blocks is included in the output is determined using the "exports"
-- argument in the block header.
codeBlock :: BlockAttributes -> String -> OrgParser (F Blocks)
codeBlock blockAttrs blockType = do
  skipSpaces
  (classes, kv)     <- codeHeaderArgs <|> (mempty <$ ignHeaders)
  content           <- rawBlockContent blockType
  resultsContent    <- trailingResultsBlock
  let id'            = fromMaybe mempty $ blockAttrName blockAttrs
  let includeCode    = exportsCode kv
  let includeResults = exportsResults kv
  let codeBlck       = B.codeBlockWith ( id', classes, kv ) content
  let labelledBlck   = maybe (pure codeBlck)
                             (labelDiv codeBlck)
                             (blockAttrCaption blockAttrs)
  let resultBlck     = fromMaybe mempty resultsContent
  return $
    (if includeCode    then labelledBlck else mempty) <>
    (if includeResults then resultBlck   else mempty)
 where
   labelDiv :: Blocks -> F Inlines -> F Blocks
   labelDiv blk value =
     B.divWith nullAttr <$> (mappend <$> labelledBlock value <*> pure blk)

   labelledBlock :: F Inlines -> F Blocks
   labelledBlock = fmap (B.plain . B.spanWith ("", ["label"], []))

exportsCode :: [(String, String)] -> Bool
exportsCode attrs = not (("rundoc-exports", "none") `elem` attrs
                         || ("rundoc-exports", "results") `elem` attrs)

exportsResults :: [(String, String)] -> Bool
exportsResults attrs = ("rundoc-exports", "results") `elem` attrs
                       || ("rundoc-exports", "both") `elem` attrs

trailingResultsBlock :: OrgParser (Maybe (F Blocks))
trailingResultsBlock = optionMaybe . try $ do
  blanklines
  stringAnyCase "#+RESULTS:"
  blankline
  block

-- | Parse code block arguments
-- TODO: We currently don't handle switches.
codeHeaderArgs :: OrgParser ([String], [(String, String)])
codeHeaderArgs = try $ do
  language   <- skipSpaces *> orgArgWord
  _          <- skipSpaces *> (try $ switch `sepBy` (many1 spaceChar))
  parameters <- manyTill blockOption newline
  let pandocLang = translateLang language
  return $
    if hasRundocParameters parameters
    then ( [ pandocLang, rundocBlockClass ]
         , map toRundocAttrib (("language", language) : parameters)
         )
    else ([ pandocLang ], parameters)
 where
   hasRundocParameters = not . null

switch :: OrgParser (Char, Maybe String)
switch = try $ simpleSwitch <|> lineNumbersSwitch
 where
   simpleSwitch = (\c -> (c, Nothing)) <$> (oneOf "-+" *> letter)
   lineNumbersSwitch = (\ls -> ('l', Just ls)) <$>
                       (string "-l \"" *> many1Till nonspaceChar (char '"'))

blockOption :: OrgParser (String, String)
blockOption = try $ do
  argKey <- orgArgKey
  paramValue <- option "yes" orgParamValue
  return (argKey, paramValue)

orgParamValue :: OrgParser String
orgParamValue = try $
  skipSpaces
    *> notFollowedBy (char ':' )
    *> many1 nonspaceChar
    <* skipSpaces

horizontalRule :: OrgParser (F Blocks)
horizontalRule = return B.horizontalRule <$ try hline


--
-- Drawers
--

-- | A generic drawer which has no special meaning for org-mode.
-- Whether or not this drawer is included in the output depends on the drawers
-- export setting.
genericDrawer :: OrgParser (F Blocks)
genericDrawer = try $ do
  name    <- map toUpper <$> drawerStart
  content <- manyTill drawerLine (try drawerEnd)
  state   <- getState
  -- Include drawer if it is explicitly included in or not explicitly excluded
  -- from the list of drawers that should be exported.  PROPERTIES drawers are
  -- never exported.
  case (exportDrawers . orgStateExportSettings $ state) of
    _           | name == "PROPERTIES" -> return mempty
    Left  names | name `elem`    names -> return mempty
    Right names | name `notElem` names -> return mempty
    _                                  -> drawerDiv name <$> parseLines content
 where
  parseLines :: [String] -> OrgParser (F Blocks)
  parseLines = parseFromString blocks . (++ "\n") . unlines

  drawerDiv :: String -> F Blocks -> F Blocks
  drawerDiv drawerName = fmap $ B.divWith (mempty, [drawerName, "drawer"], mempty)

drawerLine :: OrgParser String
drawerLine = anyLine

drawerEnd :: OrgParser String
drawerEnd = try $
  skipSpaces *> stringAnyCase ":END:" <* skipSpaces <* newline

-- | Read a :PROPERTIES: drawer and return the key/value pairs contained
-- within.
propertiesDrawer :: OrgParser Properties
propertiesDrawer = try $ do
  drawerType <- drawerStart
  guard $ map toUpper drawerType == "PROPERTIES"
  manyTill property (try drawerEnd)
 where
   property :: OrgParser (PropertyKey, PropertyValue)
   property = try $ (,) <$> key <*> value

   key :: OrgParser PropertyKey
   key = fmap toPropertyKey . try $
         skipSpaces *> char ':' *> many1Till nonspaceChar (char ':')

   value :: OrgParser PropertyValue
   value = fmap toPropertyValue . try $
           skipSpaces *> manyTill anyChar (try $ skipSpaces *> newline)


--
-- Figures
--

-- | Figures or an image paragraph (i.e. an image on a line by itself). Only
-- images with a caption attribute are interpreted as figures.
figure :: OrgParser (F Blocks)
figure = try $ do
  figAttrs <- blockAttributes
  src <- skipSpaces *> selfTarget <* skipSpaces <* endOfParagraph
  case cleanLinkString src of
    Nothing     -> mzero
    Just imgSrc -> do
      guard (isImageFilename imgSrc)
      let isFigure = not . isNothing $ blockAttrCaption figAttrs
      return $ imageBlock isFigure figAttrs imgSrc
 where
   selfTarget :: OrgParser String
   selfTarget = try $ char '[' *> linkTarget <* char ']'

   imageBlock :: Bool -> BlockAttributes -> String -> F Blocks
   imageBlock isFigure figAttrs imgSrc =
     let
       figName    = fromMaybe mempty $ blockAttrName figAttrs
       figLabel   = fromMaybe mempty $ blockAttrLabel figAttrs
       figCaption = fromMaybe mempty $ blockAttrCaption figAttrs
       figKeyVals = blockAttrKeyValues figAttrs
       attr       = (figLabel, mempty, figKeyVals)
       figTitle   = (if isFigure then withFigPrefix else id) figName
     in
       B.para . B.imageWith attr imgSrc figTitle <$> figCaption

   withFigPrefix :: String -> String
   withFigPrefix cs =
     if "fig:" `isPrefixOf` cs
     then cs
     else "fig:" ++ cs

-- | Succeeds if looking at the end of the current paragraph
endOfParagraph :: OrgParser ()
endOfParagraph = try $ skipSpaces *> newline *> endOfBlock


--
-- Examples
--

-- | Example code marked up by a leading colon.
example :: OrgParser (F Blocks)
example = try $ do
  return . return . exampleCode =<< unlines <$> many1 exampleLine
 where
   exampleLine :: OrgParser String
   exampleLine = try $ exampleLineStart *> anyLine

exampleCode :: String -> Blocks
exampleCode = B.codeBlockWith ("", ["example"], [])


--
-- Comments, Options and Metadata
--

specialLine :: OrgParser (F Blocks)
specialLine = fmap return . try $ rawExportLine <|> metaLine <|> commentLine

rawExportLine :: OrgParser Blocks
rawExportLine = try $ do
  metaLineStart
  key <- metaKey
  if key `elem` ["latex", "html", "texinfo", "beamer"]
    then B.rawBlock key <$> anyLine
    else mzero

commentLine :: OrgParser Blocks
commentLine = commentLineStart *> anyLine *> pure mempty


--
-- Tables
--
data ColumnProperty = ColumnProperty
  { columnAlignment :: Maybe Alignment
  , columnRelWidth  :: Maybe Int
  } deriving (Show, Eq)

instance Default ColumnProperty where
  def = ColumnProperty Nothing Nothing

data OrgTableRow = OrgContentRow (F [Blocks])
                 | OrgAlignRow [ColumnProperty]
                 | OrgHlineRow

-- OrgTable is strongly related to the pandoc table ADT.  Using the same
-- (i.e. pandoc-global) ADT would mean that the reader would break if the
-- global structure was to be changed, which would be bad.  The final table
-- should be generated using a builder function.
data OrgTable = OrgTable
  { orgTableColumnProperties :: [ColumnProperty]
  , orgTableHeader     :: [Blocks]
  , orgTableRows       :: [[Blocks]]
  }

table :: OrgParser (F Blocks)
table = try $ do
  blockAttrs <- blockAttributes
  lookAhead tableStart
  do
    rows <- tableRows
    let caption = fromMaybe (return mempty) $ blockAttrCaption blockAttrs
    return $ (<$> caption) . orgToPandocTable . normalizeTable =<< rowsToTable rows

orgToPandocTable :: OrgTable
                 -> Inlines
                 -> Blocks
orgToPandocTable (OrgTable colProps heads lns) caption =
  let totalWidth = if any (not . isNothing) (map columnRelWidth colProps)
                   then Just . sum $ map (fromMaybe 1 . columnRelWidth) colProps
                   else Nothing
  in B.table caption (map (convertColProp totalWidth) colProps) heads lns
 where
   convertColProp :: Maybe Int -> ColumnProperty -> (Alignment, Double)
   convertColProp totalWidth colProp =
     let
       align' = fromMaybe AlignDefault $ columnAlignment colProp
       width' = fromMaybe 0 $ (\w t -> (fromIntegral w / fromIntegral t))
                              <$> (columnRelWidth colProp)
                              <*> totalWidth
     in (align', width')

tableRows :: OrgParser [OrgTableRow]
tableRows = try $ many (tableAlignRow <|> tableHline <|> tableContentRow)

tableContentRow :: OrgParser OrgTableRow
tableContentRow = try $
  OrgContentRow . sequence <$> (tableStart *> many1Till tableContentCell newline)

tableContentCell :: OrgParser (F Blocks)
tableContentCell = try $
  fmap B.plain . trimInlinesF . mconcat <$> manyTill inline endOfCell

tableAlignRow :: OrgParser OrgTableRow
tableAlignRow = try $ do
  tableStart
  colProps <- many1Till columnPropertyCell newline
  -- Empty rows are regular (i.e. content) rows, not alignment rows.
  guard $ any (/= def) colProps
  return $ OrgAlignRow colProps

columnPropertyCell :: OrgParser ColumnProperty
columnPropertyCell = emptyCell <|> propCell <?> "alignment info"
 where
   emptyCell = ColumnProperty Nothing Nothing <$ (try $ skipSpaces *> endOfCell)
   propCell = try $ ColumnProperty
                 <$> (skipSpaces
                      *> char '<'
                      *> optionMaybe tableAlignFromChar)
                 <*> (optionMaybe (many1 digit >>= safeRead)
                      <* char '>'
                      <* emptyCell)

tableAlignFromChar :: OrgParser Alignment
tableAlignFromChar = try $
  choice [ char 'l' *> return AlignLeft
         , char 'c' *> return AlignCenter
         , char 'r' *> return AlignRight
         ]

tableHline :: OrgParser OrgTableRow
tableHline = try $
  OrgHlineRow <$ (tableStart *> char '-' *> anyLine)

endOfCell :: OrgParser Char
endOfCell = try $ char '|' <|> lookAhead newline

rowsToTable :: [OrgTableRow]
            -> F OrgTable
rowsToTable = foldM rowToContent emptyTable
 where emptyTable = OrgTable mempty mempty mempty

normalizeTable :: OrgTable -> OrgTable
normalizeTable (OrgTable colProps heads rows) =
  OrgTable colProps' heads rows
 where
   refRow = if heads /= mempty
            then heads
            else case rows of
                   (r:_) -> r
                   _     -> mempty
   cols = length refRow
   fillColumns base padding = take cols $ base ++ repeat padding
   colProps' = fillColumns colProps def

-- One or more horizontal rules after the first content line mark the previous
-- line as a header.  All other horizontal lines are discarded.
rowToContent :: OrgTable
             -> OrgTableRow
             -> F OrgTable
rowToContent orgTable row =
  case row of
    OrgHlineRow       -> return singleRowPromotedToHeader
    OrgAlignRow props -> return . setProperties $ props
    OrgContentRow cs  -> appendToBody cs
 where
   singleRowPromotedToHeader :: OrgTable
   singleRowPromotedToHeader = case orgTable of
     OrgTable{ orgTableHeader = [], orgTableRows = b:[] } ->
            orgTable{ orgTableHeader = b , orgTableRows = [] }
     _   -> orgTable

   setProperties :: [ColumnProperty] -> OrgTable
   setProperties ps = orgTable{ orgTableColumnProperties = ps }

   appendToBody :: F [Blocks] -> F OrgTable
   appendToBody frow = do
     newRow <- frow
     let oldRows = orgTableRows orgTable
     -- NOTE: This is an inefficient O(n) operation.  This should be changed
     -- if performance ever becomes a problem.
     return orgTable{ orgTableRows = oldRows ++ [newRow] }


--
-- LaTeX fragments
--
latexFragment :: OrgParser (F Blocks)
latexFragment = try $ do
  envName <- latexEnvStart
  content <- mconcat <$> manyTill anyLineNewline (latexEnd envName)
  return . return $ B.rawBlock "latex" (content `inLatexEnv` envName)
 where
   c `inLatexEnv` e = mconcat [ "\\begin{", e, "}\n"
                              , c
                              , "\\end{", e, "}\n"
                              ]

latexEnd :: String -> OrgParser ()
latexEnd envName = try $
  () <$ skipSpaces
     <* string ("\\end{" ++ envName ++ "}")
     <* blankline


--
-- Footnote defintions
--
noteBlock :: OrgParser (F Blocks)
noteBlock = try $ do
  ref <- noteMarker <* skipSpaces
  content <- mconcat <$> blocksTillHeaderOrNote
  addToNotesTable (ref, content)
  return mempty
 where
   blocksTillHeaderOrNote =
     many1Till block (eof <|> () <$ lookAhead noteMarker
                          <|> () <$ lookAhead headerStart)

-- Paragraphs or Plain text
paraOrPlain :: OrgParser (F Blocks)
paraOrPlain = try $ do
  -- Make sure we are not looking at a headline
  notFollowedBy' (char '*' *> (oneOf " *"))
  ils <- inlines
  nl <- option False (newline *> return True)
  -- Read block as paragraph, except if we are in a list context and the block
  -- is directly followed by a list item, in which case the block is read as
  -- plain text.
  try (guard nl
       *> notFollowedBy (inList *> (() <$ orderedListStart <|> bulletListStart))
       *> return (B.para <$> ils))
    <|>  (return (B.plain <$> ils))


--
-- list blocks
--

list :: OrgParser (F Blocks)
list = choice [ definitionList, bulletList, orderedList ] <?> "list"

definitionList :: OrgParser (F Blocks)
definitionList = try $ do n <- lookAhead (bulletListStart' Nothing)
                          fmap B.definitionList . fmap compactify'DL . sequence
                            <$> many1 (definitionListItem $ bulletListStart' (Just n))

bulletList :: OrgParser (F Blocks)
bulletList = try $ do n <- lookAhead (bulletListStart' Nothing)
                      fmap B.bulletList . fmap compactify' . sequence
                        <$> many1 (listItem (bulletListStart' $ Just n))

orderedList :: OrgParser (F Blocks)
orderedList = fmap B.orderedList . fmap compactify' . sequence
              <$> many1 (listItem orderedListStart)

bulletListStart' :: Maybe Int -> OrgParser Int
-- returns length of bulletList prefix, inclusive of marker
bulletListStart' Nothing  = do ind <- length <$> many spaceChar
                               oneOf (bullets $ ind == 0)
                               skipSpaces1
                               return (ind + 1)
bulletListStart' (Just n) = do count (n-1) spaceChar
                               oneOf (bullets $ n == 1)
                               many1 spaceChar
                               return n

-- Unindented lists are legal, but they can't use '*' bullets.
-- We return n to maintain compatibility with the generic listItem.
bullets :: Bool -> String
bullets unindented = if unindented then "+-" else "*+-"

definitionListItem :: OrgParser Int
                   -> OrgParser (F (Inlines, [Blocks]))
definitionListItem parseMarkerGetLength = try $ do
  markerLength <- parseMarkerGetLength
  term <- manyTill (noneOf "\n\r") (try definitionMarker)
  line1 <- anyLineNewline
  blank <- option "" ("\n" <$ blankline)
  cont <- concat <$> many (listContinuation markerLength)
  term' <- parseFromString inlines term
  contents' <- parseFromString blocks $ line1 ++ blank ++ cont
  return $ (,) <$> term' <*> fmap (:[]) contents'
 where
   definitionMarker =
     spaceChar *> string "::" <* (spaceChar <|> lookAhead newline)


-- parse raw text for one list item, excluding start marker and continuations
listItem :: OrgParser Int
         -> OrgParser (F Blocks)
listItem start = try . withContext ListItemState $ do
  markerLength <- try start
  firstLine <- anyLineNewline
  blank <- option "" ("\n" <$ blankline)
  rest <- concat <$> many (listContinuation markerLength)
  parseFromString blocks $ firstLine ++ blank ++ rest

-- continuation of a list item - indented and separated by blankline or endline.
-- Note: nested lists are parsed as continuations.
listContinuation :: Int
                 -> OrgParser String
listContinuation markerLength = try $
  notFollowedBy' blankline
  *> (mappend <$> (concat <$> many1 listLine)
              <*> many blankline)
 where
   listLine = try $ indentWith markerLength *> anyLineNewline

   -- indent by specified number of spaces (or equiv. tabs)
   indentWith :: Int -> OrgParser String
   indentWith num = do
     tabStop <- getOption readerTabStop
     if num < tabStop
       then count num (char ' ')
       else choice [ try (count num (char ' '))
                   , try (char '\t' >> count (num - tabStop) (char ' ')) ]

-- | Parse any line, include the final newline in the output.
anyLineNewline :: OrgParser String
anyLineNewline = (++ "\n") <$> anyLine