summaryrefslogtreecommitdiff
path: root/src/Text/Pandoc/Readers/Org/DocumentTree.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Text/Pandoc/Readers/Org/DocumentTree.hs')
-rw-r--r--src/Text/Pandoc/Readers/Org/DocumentTree.hs260
1 files changed, 260 insertions, 0 deletions
diff --git a/src/Text/Pandoc/Readers/Org/DocumentTree.hs b/src/Text/Pandoc/Readers/Org/DocumentTree.hs
new file mode 100644
index 000000000..53ec2ef57
--- /dev/null
+++ b/src/Text/Pandoc/Readers/Org/DocumentTree.hs
@@ -0,0 +1,260 @@
+{-
+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
+-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
+{- |
+ Module : Text.Pandoc.Readers.Org.DocumentTree
+ 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 headlines and document subtrees
+-}
+module Text.Pandoc.Readers.Org.DocumentTree
+ ( headline
+ , headlineToBlocks
+ ) where
+
+import Control.Monad (guard, void)
+import Data.Char (toLower, toUpper)
+import Data.Maybe (fromMaybe)
+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.Parsing
+import Text.Pandoc.Readers.Org.ParserState
+
+import qualified Text.Pandoc.Builder as B
+
+--
+-- 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]
+ }
+
+-- | Read an Org mode headline and its contents (i.e. a document subtree).
+-- @lvl@ gives the minimum acceptable level of the tree.
+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)
+
+-- | Convert an Org mode headline (i.e. a document tree) into pandoc's Blocks
+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")
+
+-- | 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 :: 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
+ 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 :: 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 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)
+
+-- | Convert
+tagToInline :: Tag -> Inlines
+tagToInline t = B.spanWith ("", ["tag"], [("data-tag-name", fromTag t)]) mempty
+
+-- | Read a :PROPERTIES: drawer and return the key/value pairs contained
+-- within.
+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
+
generated by cgit v1.2.3 (git 2.25.1) at 2024-04-25 17:26:40 +0000