diff options
Diffstat (limited to 'src/Text')
| -rw-r--r-- | src/Text/Pandoc/Readers/Org.hs | 84 | ||||
| -rw-r--r-- | src/Text/Pandoc/Writers/Org.hs | 23 |
2 files changed, 77 insertions, 30 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 |