git.iko.soy/typeable/pandoc
on master help sign in
Org reader: parse as headlines, convert to blocks
17484edAlbert Krewinkel
src/Text/Pandoc/Readers/Org/Blocks.hs+86−47
compare with master
unifiedsplit
@@ -1,4 +1,5 @@
1{-# LANGUAGE FlexibleContexts #-}
1{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE RecordWildCards #-}
2{-
3{-
3Copyright (C) 2014-2016 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>
4Copyright (C) 2014-2016 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>
4
5
@@ -46,7 +47,7 @@ import Text.Pandoc.Compat.Monoid ((<>))
46import Text.Pandoc.Options
47import Text.Pandoc.Options
47import Text.Pandoc.Shared ( compactify', compactify'DL )
48import Text.Pandoc.Shared ( compactify', compactify'DL )
48
49
49−import Control.Monad ( foldM, guard, mzero )
50+import Control.Monad ( foldM, guard, mzero, void )
50import Data.Char ( isSpace, toLower, toUpper)
51import Data.Char ( isSpace, toLower, toUpper)
51import Data.List ( foldl', intersperse, isPrefixOf )
52import Data.List ( foldl', intersperse, isPrefixOf )
52import qualified Data.Map as M
53import qualified Data.Map as M
@@ -82,6 +83,82 @@ toPropertyValue = PropertyValue
82-- | Key/value pairs from a PROPERTIES drawer
83-- | Key/value pairs from a PROPERTIES drawer
83type Properties = [(PropertyKey, PropertyValue)]
84type Properties = [(PropertyKey, PropertyValue)]
84
85
86+-- | Org mode headline (i.e. a document subtree).
87+data Headline = Headline
88+ { headlineLevel :: Int
89+ , headlineText :: Inlines
90+ , headlineTags :: [Tag]
91+ , headlineProperties :: Properties
92+ , headlineContents :: Blocks
93+ , headlineChildren :: [Headline]
94+ }
95+
96+--
97+-- Parsing headlines and subtrees
98+--
99+
100+-- | Read an Org mode headline and its contents (i.e. a document subtree).
101+-- @lvl@ gives the minimum acceptable level of the tree.
102+headline :: Int -> OrgParser (F Headline)
103+headline lvl = try $ do
104+ level <- headerStart
105+ guard (lvl <= level)
106+ title <- trimInlinesF . mconcat <$> manyTill inline endOfTitle
107+ tags <- option [] headerTags
108+ newline
109+ properties <- option mempty propertiesDrawer
110+ contents <- blocks
111+ children <- many (headline (lvl + 1))
112+ return $ do
113+ title' <- title
114+ contents' <- contents
115+ children' <- sequence children
116+ return $ Headline
117+ { headlineLevel = level
118+ , headlineText = title'
119+ , headlineTags = tags
120+ , headlineProperties = properties
121+ , headlineContents = contents'
122+ , headlineChildren = children'
123+ }
124+ where
125+ endOfTitle :: OrgParser ()
126+ endOfTitle = void . lookAhead $ optional headerTags *> newline
127+
128+ headerTags :: OrgParser [Tag]
129+ headerTags = try $
130+ let tag = many1 (alphaNum <|> oneOf "@%#_") <* char ':'
131+ in map toTag <$> (skipSpaces *> char ':' *> many1 tag <* skipSpaces)
132+
133+-- | Convert an Org mode headline (i.e. a document tree) into pandoc's Blocks
134+headlineToBlocks :: Headline -> OrgParser Blocks
135+headlineToBlocks (Headline {..}) = do
136+ let text = tagTitle headlineText headlineTags
137+ let propAttr = propertiesToAttr headlineProperties
138+ attr <- registerHeader propAttr headlineText
139+ let header = B.headerWith attr headlineLevel text
140+ childrenBlocks <- mconcat <$> sequence (map headlineToBlocks headlineChildren)
141+ return $ header <> headlineContents <> childrenBlocks
142+
143+propertiesToAttr :: Properties -> Attr
144+propertiesToAttr properties =
145+ let
146+ toStringPair prop = (fromKey (fst prop), fromValue (snd prop))
147+ customIdKey = toPropertyKey "custom_id"
148+ classKey = toPropertyKey "class"
149+ id' = fromMaybe mempty . fmap fromValue . lookup customIdKey $ properties
150+ cls = fromMaybe mempty . fmap fromValue . lookup classKey $ properties
151+ kvs' = map toStringPair . filter ((`notElem` [customIdKey, classKey]) . fst)
152+ $ properties
153+ in
154+ (id', words cls, kvs')
155+
156+tagTitle :: Inlines -> [Tag] -> Inlines
157+tagTitle title tags = title <> (mconcat $ map tagToInline tags)
158+
159+tagToInline :: Tag -> Inlines
160+tagToInline t = B.spanWith ("", ["tag"], [("data-tag-name", fromTag t)]) mempty
161+
85
162
86--
163--
87-- parsing blocks
164-- parsing blocks
@@ -90,9 +167,11 @@ type Properties = [(PropertyKey, PropertyValue)]
90-- | Get a list of blocks.
167-- | Get a list of blocks.
91blockList :: OrgParser [Block]
168blockList :: OrgParser [Block]
92blockList = do
169blockList = do
93− blocks' <- blocks
170+ initialBlocks <- blocks
171+ headlines <- sequence <$> manyTill (headline 1) eof
94− st <- getState
172+ st <- getState
173+ headlineBlocks <- fmap mconcat . sequence . map headlineToBlocks $ runF headlines st
95− return . B.toList $ runF blocks' st
174+ return . B.toList $ (runF initialBlocks st) <> headlineBlocks
96
175
97-- | Get the meta information safed in the state.
176-- | Get the meta information safed in the state.
98meta :: OrgParser Meta
177meta :: OrgParser Meta
@@ -101,7 +180,7 @@ meta = do
101 return $ runF (orgStateMeta st) st
180 return $ runF (orgStateMeta st) st
102
181
103blocks :: OrgParser (F Blocks)
182blocks :: OrgParser (F Blocks)
104−blocks = mconcat <$> manyTill block eof
183+blocks = mconcat <$> manyTill block (void (lookAhead headerStart) <|> eof)
105
184
106block :: OrgParser (F Blocks)
185block :: OrgParser (F Blocks)
107block = choice [ mempty <$ blanklines
186block = choice [ mempty <$ blanklines
@@ -111,7 +190,6 @@ block = choice [ mempty <$ blanklines
111 , example
190 , example
112 , genericDrawer
191 , genericDrawer
113 , specialLine
192 , specialLine
114− , header
115 , horizontalRule
193 , horizontalRule
116 , list
194 , list
117 , latexFragment
195 , latexFragment
@@ -633,47 +711,6 @@ parseFormat = try $ do
633 rest = manyTill anyChar (eof <|> () <$ oneOf "\n\r")
711 rest = manyTill anyChar (eof <|> () <$ oneOf "\n\r")
634 tillSpecifier c = manyTill (noneOf "\n\r") (try $ string ('%':c:""))
712 tillSpecifier c = manyTill (noneOf "\n\r") (try $ string ('%':c:""))
635
713
636−--
637−-- Headers
638−--
639−
640−-- | Headers
641−header :: OrgParser (F Blocks)
642−header = try $ do
643− level <- headerStart
644− title <- manyTill inline (lookAhead $ optional headerTags <* newline)
645− tags <- option [] headerTags
646− newline
647− let text = tagTitle title tags
648− propAttr <- option nullAttr (propertiesToAttr <$> propertiesDrawer)
649− attr <- registerHeader propAttr (runF text def)
650− return (B.headerWith attr level <$> text)
651− where
652− tagTitle :: [F Inlines] -> [Tag] -> F Inlines
653− tagTitle title tags = trimInlinesF . mconcat $ title <> map tagToInlineF tags
654−
655− tagToInlineF :: Tag -> F Inlines
656− tagToInlineF t =
657− return $ B.spanWith ("", ["tag"], [("data-tag-name", fromTag t)]) mempty
658−
659− headerTags :: OrgParser [Tag]
660− headerTags = try $
661− let tag = many1 (alphaNum <|> oneOf "@%#_") <* char ':'
662− in map toTag <$> (skipSpaces *> char ':' *> many1 tag <* skipSpaces)
663−
664−propertiesToAttr :: Properties -> Attr
665−propertiesToAttr properties =
666− let
667− toStringPair prop = (fromKey (fst prop), fromValue (snd prop))
668− customIdKey = toPropertyKey "custom_id"
669− classKey = toPropertyKey "class"
670− id' = fromMaybe mempty . fmap fromValue . lookup customIdKey $ properties
671− cls = fromMaybe mempty . fmap fromValue . lookup classKey $ properties
672− kvs' = map toStringPair . filter ((`notElem` [customIdKey, classKey]) . fst)
673− $ properties
674− in
675− (id', words cls, kvs')
676−
677
714
678--
715--
679-- Tables
716-- Tables
@@ -838,6 +875,8 @@ noteBlock = try $ do
838-- Paragraphs or Plain text
875-- Paragraphs or Plain text
839paraOrPlain :: OrgParser (F Blocks)
876paraOrPlain :: OrgParser (F Blocks)
840paraOrPlain = try $ do
877paraOrPlain = try $ do
878+ -- Make sure we are not looking at a headline
879+ notFollowedBy' (char '*' *> (oneOf " *"))
841 ils <- inlines
880 ils <- inlines
842 nl <- option False (newline *> return True)
881 nl <- option False (newline *> return True)
843 -- Read block as paragraph, except if we are in a list context and the block
882 -- Read block as paragraph, except if we are in a list context and the block