{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
module Text.Pandoc.Readers.Org.DocumentTree
( documentTree
, headlineToBlocks
) where
import Prelude
import Control.Arrow ((***))
import Control.Monad (guard, void)
import Data.Char (toLower, toUpper)
import Data.List (intersperse)
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