@@ -0,0 +1,260 @@
1+{-
2+Copyright (C) 2014-2017 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>
3+
4+This program is free software; you can redistribute it and/or modify
5+it under the terms of the GNU General Public License as published by
6+the Free Software Foundation; either version 2 of the License, or
7+(at your option) any later version.
8+
9+This program is distributed in the hope that it will be useful,
10+but WITHOUT ANY WARRANTY; without even the implied warranty of
11+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12+GNU General Public License for more details.
13+
14+You should have received a copy of the GNU General Public License
15+along with this program; if not, write to the Free Software
16+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
17+-}
18+{-# LANGUAGE FlexibleContexts #-}
19+{-# LANGUAGE RecordWildCards #-}
20+{-# LANGUAGE ViewPatterns #-}
21+{- |
22+ Module : Text.Pandoc.Readers.Org.DocumentTree
23+ Copyright : Copyright (C) 2014-2017 Albert Krewinkel
24+ License : GNU GPL, version 2 or above
25+
26+ Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>
27+
28+Parsers for org-mode headlines and document subtrees
29+-}
30+module Text.Pandoc.Readers.Org.DocumentTree
31+ ( headline
32+ , headlineToBlocks
33+ ) where
34+
35+import Control.Monad (guard, void)
36+import Data.Char (toLower, toUpper)
37+import Data.Maybe (fromMaybe)
38+import Data.Monoid ((<>))
39+import Text.Pandoc.Builder (Blocks, Inlines)
40+import Text.Pandoc.Class (PandocMonad)
41+import Text.Pandoc.Definition
42+import Text.Pandoc.Readers.Org.BlockStarts
43+import Text.Pandoc.Readers.Org.Parsing
44+import Text.Pandoc.Readers.Org.ParserState
45+
46+import qualified Text.Pandoc.Builder as B
47+
48+--
49+-- Org headers
50+--
51+newtype Tag = Tag { fromTag :: String }
52+ deriving (Show, Eq)
53+
54+-- | Create a tag containing the given string.
55+toTag :: String -> Tag
56+toTag = Tag
57+
58+-- | The key (also called name or type) of a property.
59+newtype PropertyKey = PropertyKey { fromKey :: String }
60+ deriving (Show, Eq, Ord)
61+
62+-- | Create a property key containing the given string. Org mode keys are
63+-- case insensitive and are hence converted to lower case.
64+toPropertyKey :: String -> PropertyKey
65+toPropertyKey = PropertyKey . map toLower
66+
67+-- | The value assigned to a property.
68+newtype PropertyValue = PropertyValue { fromValue :: String }
69+
70+-- | Create a property value containing the given string.
71+toPropertyValue :: String -> PropertyValue
72+toPropertyValue = PropertyValue
73+
74+-- | Check whether the property value is non-nil (i.e. truish).
75+isNonNil :: PropertyValue -> Bool
76+isNonNil p = map toLower (fromValue p) `notElem` ["()", "{}", "nil"]
77+
78+-- | Key/value pairs from a PROPERTIES drawer
79+type Properties = [(PropertyKey, PropertyValue)]
80+
81+-- | Org mode headline (i.e. a document subtree).
82+data Headline = Headline
83+ { headlineLevel :: Int
84+ , headlineTodoMarker :: Maybe TodoMarker
85+ , headlineText :: Inlines
86+ , headlineTags :: [Tag]
87+ , headlineProperties :: Properties
88+ , headlineContents :: Blocks
89+ , headlineChildren :: [Headline]
90+ }
91+
92+-- | Read an Org mode headline and its contents (i.e. a document subtree).
93+-- @lvl@ gives the minimum acceptable level of the tree.
94+headline :: PandocMonad m
95+ => OrgParser m (F Blocks)
96+ -> OrgParser m (F Inlines)
97+ -> Int
98+ -> OrgParser m (F Headline)
99+headline blocks inline lvl = try $ do
100+ level <- headerStart
101+ guard (lvl <= level)
102+ todoKw <- optionMaybe todoKeyword
103+ title <- trimInlinesF . mconcat <$> manyTill inline endOfTitle
104+ tags <- option [] headerTags
105+ newline
106+ properties <- option mempty propertiesDrawer
107+ contents <- blocks
108+ children <- many (headline blocks inline (level + 1))
109+ return $ do
110+ title' <- title
111+ contents' <- contents
112+ children' <- sequence children
113+ return $ Headline
114+ { headlineLevel = level
115+ , headlineTodoMarker = todoKw
116+ , headlineText = title'
117+ , headlineTags = tags
118+ , headlineProperties = properties
119+ , headlineContents = contents'
120+ , headlineChildren = children'
121+ }
122+ where
123+ endOfTitle :: Monad m => OrgParser m ()
124+ endOfTitle = void . lookAhead $ optional headerTags *> newline
125+
126+ headerTags :: Monad m => OrgParser m [Tag]
127+ headerTags = try $
128+ let tag = many1 (alphaNum <|> oneOf "@%#_") <* char ':'
129+ in map toTag <$> (skipSpaces *> char ':' *> many1 tag <* skipSpaces)
130+
131+-- | Convert an Org mode headline (i.e. a document tree) into pandoc's Blocks
132+headlineToBlocks :: Monad m => Headline -> OrgParser m Blocks
133+headlineToBlocks hdln@(Headline {..}) = do
134+ maxHeadlineLevels <- getExportSetting exportHeadlineLevels
135+ case () of
136+ _ | any isNoExportTag headlineTags -> return mempty
137+ _ | any isArchiveTag headlineTags -> archivedHeadlineToBlocks hdln
138+ _ | isCommentTitle headlineText -> return mempty
139+ _ | headlineLevel >= maxHeadlineLevels -> headlineToHeaderWithList hdln
140+ _ | otherwise -> headlineToHeaderWithContents hdln
141+
142+isNoExportTag :: Tag -> Bool
143+isNoExportTag = (== toTag "noexport")
144+
145+isArchiveTag :: Tag -> Bool
146+isArchiveTag = (== toTag "ARCHIVE")
147+
148+-- | Check if the title starts with COMMENT.
149+-- FIXME: This accesses builder internals not intended for use in situations
150+-- like these. Replace once keyword parsing is supported.
151+isCommentTitle :: Inlines -> Bool
152+isCommentTitle (B.toList -> (Str "COMMENT":_)) = True
153+isCommentTitle _ = False
154+
155+archivedHeadlineToBlocks :: Monad m => Headline -> OrgParser m Blocks
156+archivedHeadlineToBlocks hdln = do
157+ archivedTreesOption <- getExportSetting exportArchivedTrees
158+ case archivedTreesOption of
159+ ArchivedTreesNoExport -> return mempty
160+ ArchivedTreesExport -> headlineToHeaderWithContents hdln
161+ ArchivedTreesHeadlineOnly -> headlineToHeader hdln
162+
163+headlineToHeaderWithList :: Monad m => Headline -> OrgParser m Blocks
164+headlineToHeaderWithList hdln@(Headline {..}) = do
165+ maxHeadlineLevels <- getExportSetting exportHeadlineLevels
166+ header <- headlineToHeader hdln
167+ listElements <- sequence (map headlineToBlocks headlineChildren)
168+ let listBlock = if null listElements
169+ then mempty
170+ else B.orderedList listElements
171+ let headerText = if maxHeadlineLevels == headlineLevel
172+ then header
173+ else flattenHeader header
174+ return $ headerText <> headlineContents <> listBlock
175+ where
176+ flattenHeader :: Blocks -> Blocks
177+ flattenHeader blks =
178+ case B.toList blks of
179+ (Header _ _ inlns:_) -> B.para (B.fromList inlns)
180+ _ -> mempty
181+
182+headlineToHeaderWithContents :: Monad m => Headline -> OrgParser m Blocks
183+headlineToHeaderWithContents hdln@(Headline {..}) = do
184+ header <- headlineToHeader hdln
185+ childrenBlocks <- mconcat <$> sequence (map headlineToBlocks headlineChildren)
186+ return $ header <> headlineContents <> childrenBlocks
187+
188+headlineToHeader :: Monad m => Headline -> OrgParser m Blocks
189+headlineToHeader (Headline {..}) = do
190+ exportTodoKeyword <- getExportSetting exportWithTodoKeywords
191+ let todoText = if exportTodoKeyword
192+ then case headlineTodoMarker of
193+ Just kw -> todoKeywordToInlines kw <> B.space
194+ Nothing -> mempty
195+ else mempty
196+ let text = tagTitle (todoText <> headlineText) headlineTags
197+ let propAttr = propertiesToAttr headlineProperties
198+ attr <- registerHeader propAttr headlineText
199+ return $ B.headerWith attr headlineLevel text
200+
201+todoKeyword :: Monad m => OrgParser m TodoMarker
202+todoKeyword = try $ do
203+ taskStates <- activeTodoMarkers <$> getState
204+ let kwParser tdm = try $ (tdm <$ string (todoMarkerName tdm) <* spaceChar)
205+ choice (map kwParser taskStates)
206+
207+todoKeywordToInlines :: TodoMarker -> Inlines
208+todoKeywordToInlines tdm =
209+ let todoText = todoMarkerName tdm
210+ todoState = map toLower . show $ todoMarkerState tdm
211+ classes = [todoState, todoText]
212+ in B.spanWith (mempty, classes, mempty) (B.str todoText)
213+
214+propertiesToAttr :: Properties -> Attr
215+propertiesToAttr properties =
216+ let
217+ toStringPair prop = (fromKey (fst prop), fromValue (snd prop))
218+ customIdKey = toPropertyKey "custom_id"
219+ classKey = toPropertyKey "class"
220+ unnumberedKey = toPropertyKey "unnumbered"
221+ specialProperties = [customIdKey, classKey, unnumberedKey]
222+ id' = fromMaybe mempty . fmap fromValue . lookup customIdKey $ properties
223+ cls = fromMaybe mempty . fmap fromValue . lookup classKey $ properties
224+ kvs' = map toStringPair . filter ((`notElem` specialProperties) . fst)
225+ $ properties
226+ isUnnumbered =
227+ fromMaybe False . fmap isNonNil . lookup unnumberedKey $ properties
228+ in
229+ (id', words cls ++ (if isUnnumbered then ["unnumbered"] else []), kvs')
230+
231+tagTitle :: Inlines -> [Tag] -> Inlines
232+tagTitle title tags = title <> (mconcat $ map tagToInline tags)
233+
234+-- | Convert
235+tagToInline :: Tag -> Inlines
236+tagToInline t = B.spanWith ("", ["tag"], [("data-tag-name", fromTag t)]) mempty
237+
238+-- | Read a :PROPERTIES: drawer and return the key/value pairs contained
239+-- within.
240+propertiesDrawer :: Monad m => OrgParser m Properties
241+propertiesDrawer = try $ do
242+ drawerType <- drawerStart
243+ guard $ map toUpper drawerType == "PROPERTIES"
244+ manyTill property (try endOfDrawer)
245+ where
246+ property :: Monad m => OrgParser m (PropertyKey, PropertyValue)
247+ property = try $ (,) <$> key <*> value
248+
249+ key :: Monad m => OrgParser m PropertyKey
250+ key = fmap toPropertyKey . try $
251+ skipSpaces *> char ':' *> many1Till nonspaceChar (char ':')
252+
253+ value :: Monad m => OrgParser m PropertyValue
254+ value = fmap toPropertyValue . try $
255+ skipSpaces *> manyTill anyChar (try $ skipSpaces *> newline)
256+
257+ endOfDrawer :: Monad m => OrgParser m String
258+ endOfDrawer = try $
259+ skipSpaces *> stringAnyCase ":END:" <* skipSpaces <* newline
260+