module Text.Pandoc.Readers.Org.DocumentTree
( documentTree
, headlineToBlocks
) where
import Control.Arrow ((***))
import Control.Monad (guard, void)
import Data.Char (toLower, toUpper)
import Data.List (intersperse)
import Data.Monoid ((<>))
import Text.Pandoc.Builder (Blocks, Inlines)
import Text.Pandoc.Class (PandocMonad)
import Text.Pandoc.Definition
import Text.Pandoc.Readers.Org.BlockStarts
import Text.Pandoc.Readers.Org.ParserState
import Text.Pandoc.Readers.Org.Parsing
import qualified Data.Map as Map
import qualified Text.Pandoc.Builder as B
documentTree :: PandocMonad m
=> OrgParser m (F Blocks)
-> OrgParser m (F Inlines)
-> OrgParser m (F Headline)
documentTree blocks inline = do
initialBlocks <- blocks
headlines <- sequence <$> manyTill (headline blocks inline 1) eof
title <- fmap (getTitle . unMeta) . orgStateMeta <$> getState
return $ do
headlines' <- headlines
initialBlocks' <- initialBlocks
title' <- title
return Headline
{ headlineLevel = 0
, headlineTodoMarker = Nothing
, headlineText = B.fromList title'
, headlineTags = mempty
, headlineProperties = mempty
, headlineContents = initialBlocks'
, headlineChildren = headlines'
}
where
getTitle :: Map.Map String MetaValue -> [Inline]
getTitle metamap =
case Map.lookup "title" metamap of
Just (MetaInlines inlns) -> inlns
_ -> []
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 :: PandocMonad m
=> OrgParser m (F Blocks)
-> OrgParser m (F Inlines)
-> Int
-> OrgParser m (F Headline)
headline blocks inline 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 blocks inline (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 :: Monad m => OrgParser m ()
endOfTitle = void . lookAhead $ optional headerTags *> newline
headerTags :: Monad m => OrgParser m [Tag]
headerTags = try $
let tag = many1 (alphaNum <|> oneOf "@%#_") <* char ':'
in map toTag <$> (skipSpaces *> char ':' *> many1 tag <* skipSpaces)
headlineToBlocks :: Monad m => Headline -> OrgParser m 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 :: Monad m => Headline -> OrgParser m Blocks
archivedHeadlineToBlocks hdln = do
archivedTreesOption <- getExportSetting exportArchivedTrees
case archivedTreesOption of
ArchivedTreesNoExport -> return mempty
ArchivedTreesExport -> headlineToHeaderWithContents hdln
ArchivedTreesHeadlineOnly -> headlineToHeader hdln
headlineToHeaderWithList :: Monad m => Headline -> OrgParser m Blocks
headlineToHeaderWithList hdln@Headline {..} = do
maxHeadlineLevels <- getExportSetting exportHeadlineLevels
header <- headlineToHeader hdln
listElements <- mapM 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 :: Monad m => Headline -> OrgParser m Blocks
headlineToHeaderWithContents hdln@Headline {..} = do
header <- headlineToHeader hdln
childrenBlocks <- mconcat <$> mapM headlineToBlocks headlineChildren
return $ header <> headlineContents <> childrenBlocks
headlineToHeader :: Monad m => Headline -> OrgParser m Blocks
headlineToHeader Headline {..} = do
exportTodoKeyword <- getExportSetting exportWithTodoKeywords
exportTags <- getExportSetting exportWithTags
let todoText = if exportTodoKeyword
then case headlineTodoMarker of
Just kw -> todoKeywordToInlines kw <> B.space
Nothing -> mempty
else mempty
let text = todoText <> headlineText <>
if exportTags
then tagsToInlines headlineTags
else mempty
let propAttr = propertiesToAttr headlineProperties
attr <- registerHeader propAttr headlineText
return $ B.headerWith attr headlineLevel text
todoKeyword :: Monad m => OrgParser m 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 = fromKey *** fromValue
customIdKey = toPropertyKey "custom_id"
classKey = toPropertyKey "class"
unnumberedKey = toPropertyKey "unnumbered"
specialProperties = [customIdKey, classKey, unnumberedKey]
id' = maybe mempty fromValue . lookup customIdKey $ properties
cls = maybe mempty fromValue . lookup classKey $ properties
kvs' = map toStringPair . filter ((`notElem` specialProperties) . fst)
$ properties
isUnnumbered =
maybe False isNonNil . lookup unnumberedKey $ properties
in
(id', words cls ++ ["unnumbered" | isUnnumbered], kvs')
tagsToInlines :: [Tag] -> Inlines
tagsToInlines [] = mempty
tagsToInlines tags =
(B.space <>) . mconcat . intersperse (B.str "\160") . map tagToInline $ tags
where
tagToInline :: Tag -> Inlines
tagToInline t = tagSpan t . B.smallcaps . B.str $ fromTag t
tagSpan :: Tag -> Inlines -> Inlines
tagSpan t = B.spanWith ("", ["tag"], [("tag-name", fromTag t)])
propertiesDrawer :: Monad m => OrgParser m Properties
propertiesDrawer = try $ do
drawerType <- drawerStart
guard $ map toUpper drawerType == "PROPERTIES"
manyTill property (try endOfDrawer)
where
property :: Monad m => OrgParser m (PropertyKey, PropertyValue)
property = try $ (,) <$> key <*> value
key :: Monad m => OrgParser m PropertyKey
key = fmap toPropertyKey . try $
skipSpaces *> char ':' *> many1Till nonspaceChar (char ':')
value :: Monad m => OrgParser m PropertyValue
value = fmap toPropertyValue . try $
skipSpaces *> manyTill anyChar (try $ skipSpaces *> newline)
endOfDrawer :: Monad m => OrgParser m String
endOfDrawer = try $
skipSpaces *> stringAnyCase ":END:" <* skipSpaces <* newline