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 ((<>))
newtype Tag = Tag { fromTag :: String }
deriving (Show, Eq)
toTag :: String -> Tag
toTag = Tag
newtype PropertyKey = PropertyKey { fromKey :: String }
deriving (Show, Eq, Ord)
toPropertyKey :: String -> PropertyKey
toPropertyKey = PropertyKey . map toLower
newtype PropertyValue = PropertyValue { fromValue :: String }
toPropertyValue :: String -> PropertyValue
toPropertyValue = PropertyValue
isNonNil :: PropertyValue -> Bool
isNonNil p = map toLower (fromValue p) `notElem` ["()", "{}", "nil"]
type Properties = [(PropertyKey, PropertyValue)]
data Headline = Headline
{ headlineLevel :: Int
, headlineTodoMarker :: Maybe TodoMarker
, headlineText :: Inlines
, headlineTags :: [Tag]
, headlineProperties :: Properties
, headlineContents :: Blocks
, headlineChildren :: [Headline]
}
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)
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")
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
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
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"
data BlockAttributes = BlockAttributes
{ blockAttrName :: Maybe String
, blockAttrLabel :: Maybe String
, blockAttrCaption :: Maybe (F Inlines)
, blockAttrKeyValues :: [(String, String)]
}
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
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")
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
ignHeaders :: OrgParser ()
ignHeaders = (() <$ newline) <|> (() <$ anyLine)
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
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)
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
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
genericDrawer :: OrgParser (F Blocks)
genericDrawer = try $ do
name <- map toUpper <$> drawerStart
content <- manyTill drawerLine (try drawerEnd)
state <- getState
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
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)
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
endOfParagraph :: OrgParser ()
endOfParagraph = try $ skipSpaces *> newline *> endOfBlock
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"], [])
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
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
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
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
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
return orgTable{ orgTableRows = oldRows ++ [newRow] }
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
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)
paraOrPlain :: OrgParser (F Blocks)
paraOrPlain = try $ do
notFollowedBy' (char '*' *> (oneOf " *"))
ils <- inlines
nl <- option False (newline *> return True)
try (guard nl
*> notFollowedBy (inList *> (() <$ orderedListStart <|> bulletListStart))
*> return (B.para <$> ils))
<|> (return (B.plain <$> ils))
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
bulletListStart' Nothing = do ind <- length <$> many spaceChar
oneOf (bullets $ ind == 0)
skipSpaces1
return (ind + 1)
bulletListStart' (Just n) = do count (n1) spaceChar
oneOf (bullets $ n == 1)
many1 spaceChar
return n
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)
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
listContinuation :: Int
-> OrgParser String
listContinuation markerLength = try $
notFollowedBy' blankline
*> (mappend <$> (concat <$> many1 listLine)
<*> many blankline)
where
listLine = try $ indentWith markerLength *> anyLineNewline
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 ' ')) ]
anyLineNewline :: OrgParser String
anyLineNewline = (++ "\n") <$> anyLine