diff options
| -rw-r--r-- | src/Text/Pandoc/Readers/Org.hs | 84 | ||||
| -rw-r--r-- | src/Text/Pandoc/Writers/Org.hs | 23 | ||||
| -rw-r--r-- | tests/Tests/Readers/Org.hs | 19 | ||||
| -rw-r--r-- | tests/writer.org | 93 |
4 files changed, 184 insertions, 35 deletions
diff --git a/src/Text/Pandoc/Readers/Org.hs b/src/Text/Pandoc/Readers/Org.hs index a7120389f..d7939c95a 100644 --- a/src/Text/Pandoc/Readers/Org.hs +++ b/src/Text/Pandoc/Readers/Org.hs @@ -284,7 +284,7 @@ block = choice [ mempty <$ blanklines , orgBlock , figure , example - , drawer + , genericDrawer , specialLine , header , return <$> hline @@ -582,26 +582,55 @@ exampleCode = B.codeBlockWith ("", ["example"], []) exampleLine :: OrgParser String exampleLine = try $ skipSpaces *> string ": " *> anyLine --- Drawers for properties or a logbook -drawer :: OrgParser (F Blocks) -drawer = try $ do + +-- +-- Drawers +-- + +-- | A generic drawer which has no special meaning for org-mode. +genericDrawer :: OrgParser (F Blocks) +genericDrawer = try $ do drawerStart manyTill drawerLine (try drawerEnd) return mempty drawerStart :: OrgParser String drawerStart = try $ - skipSpaces *> drawerName <* skipSpaces <* P.newline - where drawerName = try $ char ':' *> validDrawerName <* char ':' - validDrawerName = stringAnyCase "PROPERTIES" - <|> stringAnyCase "LOGBOOK" + skipSpaces *> drawerName <* skipSpaces <* newline + where drawerName = char ':' *> manyTill nonspaceChar (char ':') drawerLine :: OrgParser String -drawerLine = try anyLine +drawerLine = anyLine drawerEnd :: OrgParser String drawerEnd = try $ - skipSpaces *> stringAnyCase ":END:" <* skipSpaces <* P.newline + skipSpaces *> stringAnyCase ":END:" <* skipSpaces <* newline + +-- | Read a :PROPERTIES: drawer and return the key/value pairs contained +-- within. +propertiesDrawer :: OrgParser [(String, String)] +propertiesDrawer = try $ do + drawerType <- drawerStart + guard $ map toUpper drawerType == "PROPERTIES" + manyTill property (try drawerEnd) + where + property :: OrgParser (String, String) + property = try $ (,) <$> key <*> value + + key :: OrgParser String + key = try $ skipSpaces *> char ':' *> many1Till nonspaceChar (char ':') + + value :: OrgParser String + value = try $ skipSpaces *> manyTill anyChar (try $ skipSpaces *> P.newline) + +keyValuesToAttr :: [(String, String)] -> Attr +keyValuesToAttr kvs = + let + id' = fromMaybe mempty . lookup "id" $ kvs + cls = fromMaybe mempty . lookup "class" $ kvs + kvs' = filter (flip notElem ["id", "class"] . fst) kvs + in + (id', words cls, kvs') -- @@ -700,29 +729,28 @@ parseFormat = try $ do -- | Headers header :: OrgParser (F Blocks) header = try $ do - level <- headerStart - title <- manyTill inline (lookAhead headerEnd) - tags <- headerEnd - let inlns = trimInlinesF . mconcat $ title <> map tagToInlineF tags - st <- getState - let inlines = runF inlns st - attr <- registerHeader nullAttr inlines + level <- headerStart + title <- manyTill inline (lookAhead $ optional headerTags <* P.newline) + tags <- option [] headerTags + newline + propAttr <- option nullAttr (keyValuesToAttr <$> propertiesDrawer) + inlines <- runF (tagTitle title tags) <$> getState + attr <- registerHeader propAttr inlines return $ pure (B.headerWith attr level inlines) where + tagTitle :: [F Inlines] -> [String] -> F Inlines + tagTitle title tags = trimInlinesF . mconcat $ title <> map tagToInlineF tags + tagToInlineF :: String -> F Inlines tagToInlineF t = return $ B.spanWith ("", ["tag"], [("data-tag-name", t)]) mempty -headerEnd :: OrgParser [String] -headerEnd = option [] headerTags <* newline - -headerTags :: OrgParser [String] -headerTags = try $ - skipSpaces - *> char ':' - *> many1 tag - <* skipSpaces - where tag = many1 (alphaNum <|> oneOf "@%#_") - <* char ':' + headerTags :: OrgParser [String] + headerTags = try $ + let tag = many1 (alphaNum <|> oneOf "@%#_") <* char ':' + in skipSpaces + *> char ':' + *> many1 tag + <* skipSpaces headerStart :: OrgParser Int headerStart = try $ diff --git a/src/Text/Pandoc/Writers/Org.hs b/src/Text/Pandoc/Writers/Org.hs index e57a6fc11..bc400c998 100644 --- a/src/Text/Pandoc/Writers/Org.hs +++ b/src/Text/Pandoc/Writers/Org.hs @@ -137,10 +137,13 @@ blockToOrg (RawBlock f str) | isRawFormat f = return $ text str blockToOrg (RawBlock _ _) = return empty blockToOrg HorizontalRule = return $ blankline $$ "--------------" $$ blankline -blockToOrg (Header level _ inlines) = do +blockToOrg (Header level attr inlines) = do contents <- inlineListToOrg inlines let headerStr = text $ if level > 999 then " " else replicate level '*' - return $ headerStr <> " " <> contents <> blankline + let drawerStr = if attr == nullAttr + then empty + else cr <> nest (level + 1) (propertiesDrawer attr) + return $ headerStr <> " " <> contents <> drawerStr <> blankline blockToOrg (CodeBlock (_,classes,_) str) = do opts <- stOptions <$> get let tabstop = writerTabStop opts @@ -230,6 +233,22 @@ definitionListItemToOrg (label, defs) = do contents <- liftM vcat $ mapM blockListToOrg defs return $ hang 3 "- " $ label' <> " :: " <> (contents <> cr) +-- | Convert list of key/value pairs to Org :PROPERTIES: drawer. +propertiesDrawer :: Attr -> Doc +propertiesDrawer (ident, classes, kv) = + let + drawerStart = text ":PROPERTIES:" + drawerEnd = text ":END:" + kv' = if (classes == mempty) then kv else ("class", unwords classes):kv + kv'' = if (ident == mempty) then kv' else ("id", ident):kv' + properties = vcat $ map kvToOrgProperty kv'' + in + drawerStart <> cr <> properties <> cr <> drawerEnd + where + kvToOrgProperty :: (String, String) -> Doc + kvToOrgProperty (key, value) = + text ":" <> text key <> text ": " <> text value <> cr + -- | Convert list of Pandoc block elements to Org. blockListToOrg :: [Block] -- ^ List of block elements -> State WriterState Doc diff --git a/tests/Tests/Readers/Org.hs b/tests/Tests/Readers/Org.hs index 666d93a51..6f5a1bd50 100644 --- a/tests/Tests/Readers/Org.hs +++ b/tests/Tests/Readers/Org.hs @@ -412,17 +412,17 @@ tests = ] =?> para "Before" <> para "After" - , "Drawer start is the only text in first line of a drawer" =: + , "Drawer markers must be the only text in the line" =: unlines [ " :LOGBOOK: foo" - , " :END:" + , " :END: bar" ] =?> - para (":LOGBOOK:" <> space <> "foo" <> softbreak <> ":END:") + para (":LOGBOOK: foo" <> softbreak <> ":END: bar") - , "Drawers with unknown names are just text" =: + , "Drawers can be arbitrary" =: unlines [ ":FOO:" , ":END:" ] =?> - para (":FOO:" <> softbreak <> ":END:") + (mempty::Blocks) , "Anchor reference" =: unlines [ "<<link-here>> Target." @@ -597,6 +597,15 @@ tests = , headerWith ("but-this-is", [], []) 2 "But this is" ] + , "Preferences are treated as header attributes" =: + unlines [ "* foo" + , " :PROPERTIES:" + , " :id: fubar" + , " :bar: baz" + , " :END:" + ] =?> + headerWith ("fubar", [], [("bar", "baz")]) 1 "foo" + , "Paragraph starting with an asterisk" =: "*five" =?> para "*five" diff --git a/tests/writer.org b/tests/writer.org index 13bacdfa6..58ea5d033 100644 --- a/tests/writer.org +++ b/tests/writer.org @@ -9,30 +9,60 @@ markdown test suite. -------------- * Headers + :PROPERTIES: + :id: headers + :END: ** Level 2 with an [[/url][embedded link]] + :PROPERTIES: + :id: level-2-with-an-embedded-link + :END: *** Level 3 with /emphasis/ + :PROPERTIES: + :id: level-3-with-emphasis + :END: **** Level 4 + :PROPERTIES: + :id: level-4 + :END: ***** Level 5 + :PROPERTIES: + :id: level-5 + :END: * Level 1 + :PROPERTIES: + :id: level-1 + :END: ** Level 2 with /emphasis/ + :PROPERTIES: + :id: level-2-with-emphasis + :END: *** Level 3 + :PROPERTIES: + :id: level-3 + :END: with no blank line ** Level 2 + :PROPERTIES: + :id: level-2 + :END: with no blank line -------------- * Paragraphs + :PROPERTIES: + :id: paragraphs + :END: Here's a regular paragraph. @@ -48,6 +78,9 @@ here. -------------- * Block Quotes + :PROPERTIES: + :id: block-quotes + :END: E-mail style: @@ -87,6 +120,9 @@ And a following paragraph. -------------- * Code Blocks + :PROPERTIES: + :id: code-blocks + :END: Code: @@ -111,8 +147,14 @@ And: -------------- * Lists + :PROPERTIES: + :id: lists + :END: ** Unordered + :PROPERTIES: + :id: unordered + :END: Asterisks tight: @@ -157,6 +199,9 @@ Minuses loose: - Minus 3 ** Ordered + :PROPERTIES: + :id: ordered + :END: Tight: @@ -197,6 +242,9 @@ Multiple paragraphs: 3. Item 3. ** Nested + :PROPERTIES: + :id: nested + :END: - Tab @@ -228,6 +276,9 @@ Same thing but with paragraphs: 3. Third ** Tabs and spaces + :PROPERTIES: + :id: tabs-and-spaces + :END: - this is a list item indented with tabs @@ -238,6 +289,9 @@ Same thing but with paragraphs: - this is an example list item indented with spaces ** Fancy list markers + :PROPERTIES: + :id: fancy-list-markers + :END: 2) begins with 2 3) and now 3 @@ -276,6 +330,9 @@ B. Williams -------------- * Definition Lists + :PROPERTIES: + :id: definition-lists + :END: Tight using spaces: @@ -342,6 +399,9 @@ Blank line after term, indented marker, alternate markers: 2. sublist * HTML Blocks + :PROPERTIES: + :id: html-blocks + :END: Simple block on one line: @@ -569,6 +629,9 @@ Hr's: -------------- * Inline Markup + :PROPERTIES: + :id: inline-markup + :END: This is /emphasized/, and so /is this/. @@ -598,6 +661,9 @@ spaces: a\^b c\^d, a~b c~d. -------------- * Smart quotes, ellipses, dashes + :PROPERTIES: + :id: smart-quotes-ellipses-dashes + :END: "Hello," said the spider. "'Shelob' is my name." @@ -619,6 +685,9 @@ Ellipses...and...and.... -------------- * LaTeX + :PROPERTIES: + :id: latex + :END: - \cite[22-23]{smith.1899} - $2+2=4$ @@ -649,6 +718,9 @@ Cat & 1 \\ \hline -------------- * Special Characters + :PROPERTIES: + :id: special-characters + :END: Here is some unicode: @@ -703,8 +775,14 @@ Minus: - -------------- * Links + :PROPERTIES: + :id: links + :END: ** Explicit + :PROPERTIES: + :id: explicit + :END: Just a [[/url/][URL]]. @@ -725,6 +803,9 @@ Just a [[/url/][URL]]. [[][Empty]]. ** Reference + :PROPERTIES: + :id: reference + :END: Foo [[/url/][bar]]. @@ -753,6 +834,9 @@ Foo [[/url/][bar]]. Foo [[/url/][biz]]. ** With ampersands + :PROPERTIES: + :id: with-ampersands + :END: Here's a [[http://example.com/?foo=1&bar=2][link with an ampersand in the URL]]. @@ -764,6 +848,9 @@ Here's an [[/script?foo=1&bar=2][inline link]]. Here's an [[/script?foo=1&bar=2][inline link in pointy braces]]. ** Autolinks + :PROPERTIES: + :id: autolinks + :END: With an ampersand: [[http://example.com/?foo=1&bar=2]] @@ -786,6 +873,9 @@ Auto-links should not occur here: =<http://example.com/>= -------------- * Images + :PROPERTIES: + :id: images + :END: From "Voyage dans la Lune" by Georges Melies (1902): @@ -797,6 +887,9 @@ Here is a movie [[movie.jpg]] icon. -------------- * Footnotes + :PROPERTIES: + :id: footnotes + :END: Here is a footnote reference, [1] and another. [2] This should /not/ be a footnote reference, because it contains a space.[\^my note] Here is an inline |