Org reader: add support for todo-markers
Headlines can have optional todo-markers which can be controlled via the `#+TODO`, `#+SEQ_TODO`, or `#+TYP_TODO` meta directive. Multiple such directives can be given, each adding a new set of recognized todo-markers. If no custom todo-markers are defined, the default `TODO` and `DONE` markers are used. Todo-markers are conceptually separate from headline text and are hence excluded when autogenerating headline IDs. The markers are rendered as spans and labelled with two classes: One class is the markers name, the other signals the todo-state of the marker (either `todo` or `done`).
This commit is contained in:
Albert Krewinkel
parent
d2bc983455
commit
d5182778c4
4 changed files with 257 additions and 124 deletions
|
|
@ -90,6 +90,7 @@ 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
|
||||
|
|
@ -107,6 +108,7 @@ headline :: Int -> OrgParser (F Headline)
|
|||
headline lvl = try $ do
|
||||
level <- headerStart
|
||||
guard (lvl <= level)
|
||||
todoKw <- optionMaybe todoKeyword
|
||||
title <- trimInlinesF . mconcat <$> manyTill inline endOfTitle
|
||||
tags <- option [] headerTags
|
||||
newline
|
||||
|
|
@ -119,6 +121,7 @@ headline lvl = try $ do
|
|||
children' <- sequence children
|
||||
return $ Headline
|
||||
{ headlineLevel = level
|
||||
, headlineTodoMarker = todoKw
|
||||
, headlineText = title'
|
||||
, headlineTags = tags
|
||||
, headlineProperties = properties
|
||||
|
|
@ -193,11 +196,27 @@ headlineToHeaderWithContents hdln@(Headline {..}) = do
|
|||
|
||||
headlineToHeader :: Headline -> OrgParser Blocks
|
||||
headlineToHeader (Headline {..}) = do
|
||||
let text = tagTitle headlineText headlineTags
|
||||
let todoText = case headlineTodoMarker of
|
||||
Just kw -> todoKeywordToInlines kw <> B.space
|
||||
Nothing -> mempty
|
||||
let text = tagTitle (todoText <> headlineText) headlineTags
|
||||
let propAttr = propertiesToAttr headlineProperties
|
||||
attr <- registerHeader propAttr headlineText
|
||||
return $ B.headerWith attr headlineLevel text
|
||||
|
||||
todoKeyword :: OrgParser 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
|
||||
|
|
|
|||
|
|
@ -42,11 +42,11 @@ import qualified Text.Pandoc.Builder as B
|
|||
import Text.Pandoc.Builder ( Blocks, Inlines )
|
||||
import Text.Pandoc.Definition
|
||||
|
||||
import Control.Monad ( mzero )
|
||||
import Control.Monad ( mzero, void )
|
||||
import Data.Char ( toLower )
|
||||
import Data.List ( intersperse )
|
||||
import qualified Data.Map as M
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Monoid ( (<>) )
|
||||
import Network.HTTP ( urlEncode )
|
||||
|
||||
-- | Returns the current meta, respecting export options.
|
||||
|
|
@ -144,8 +144,11 @@ optionLine :: OrgParser ()
|
|||
optionLine = try $ do
|
||||
key <- metaKey
|
||||
case key of
|
||||
"link" -> parseLinkFormat >>= uncurry addLinkFormat
|
||||
"options" -> exportSettings
|
||||
"link" -> parseLinkFormat >>= uncurry addLinkFormat
|
||||
"options" -> exportSettings
|
||||
"todo" -> todoSequence >>= updateState . registerTodoSequence
|
||||
"seq_todo" -> todoSequence >>= updateState . registerTodoSequence
|
||||
"typ_todo" -> todoSequence >>= updateState . registerTodoSequence
|
||||
_ -> mzero
|
||||
|
||||
addLinkFormat :: String
|
||||
|
|
@ -179,3 +182,35 @@ parseFormat = try $ do
|
|||
|
||||
inlinesTillNewline :: OrgParser (F Inlines)
|
||||
inlinesTillNewline = trimInlinesF . mconcat <$> manyTill inline newline
|
||||
|
||||
--
|
||||
-- ToDo Sequences and Keywords
|
||||
--
|
||||
todoSequence :: OrgParser TodoSequence
|
||||
todoSequence = try $ do
|
||||
todoKws <- todoKeywords
|
||||
doneKws <- optionMaybe $ todoDoneSep *> todoKeywords
|
||||
newline
|
||||
-- There must be at least one DONE keyword. The last TODO keyword is taken if
|
||||
-- necessary.
|
||||
case doneKws of
|
||||
Just done -> return $ keywordsToSequence todoKws done
|
||||
Nothing -> case reverse todoKws of
|
||||
[] -> mzero -- no keywords present
|
||||
(x:xs) -> return $ keywordsToSequence (reverse xs) [x]
|
||||
|
||||
where
|
||||
todoKeywords :: OrgParser [String]
|
||||
todoKeywords = try $
|
||||
let keyword = many1 nonspaceChar <* skipSpaces
|
||||
endOfKeywords = todoDoneSep <|> void newline
|
||||
in manyTill keyword (lookAhead endOfKeywords)
|
||||
|
||||
todoDoneSep :: OrgParser ()
|
||||
todoDoneSep = void . try $ skipSpaces *> char '|' <* skipSpaces1
|
||||
|
||||
keywordsToSequence :: [String] -> [String] -> TodoSequence
|
||||
keywordsToSequence todo done =
|
||||
let todoMarkers = map (TodoMarker Todo) todo
|
||||
doneMarkers = map (TodoMarker Done) done
|
||||
in todoMarkers ++ doneMarkers
|
||||
|
|
|
|||
|
|
@ -34,6 +34,11 @@ module Text.Pandoc.Readers.Org.ParserState
|
|||
, OrgNoteRecord
|
||||
, HasReaderOptions (..)
|
||||
, HasQuoteContext (..)
|
||||
, TodoMarker (..)
|
||||
, TodoSequence
|
||||
, TodoState (..)
|
||||
, activeTodoMarkers
|
||||
, registerTodoSequence
|
||||
, F(..)
|
||||
, askF
|
||||
, asksF
|
||||
|
|
@ -72,6 +77,20 @@ type OrgNoteTable = [OrgNoteRecord]
|
|||
-- link-type, the corresponding function transforms the given link string.
|
||||
type OrgLinkFormatters = M.Map String (String -> String)
|
||||
|
||||
-- | The states in which a todo item can be
|
||||
data TodoState = Todo | Done
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
-- | A ToDo keyword like @TODO@ or @DONE@.
|
||||
data TodoMarker = TodoMarker
|
||||
{ todoMarkerState :: TodoState
|
||||
, todoMarkerName :: String
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | Collection of todo markers in the order in which items should progress
|
||||
type TodoSequence = [TodoMarker]
|
||||
|
||||
-- | Org-mode parser state
|
||||
data OrgParserState = OrgParserState
|
||||
{ orgStateAnchorIds :: [String]
|
||||
|
|
@ -88,6 +107,7 @@ data OrgParserState = OrgParserState
|
|||
, orgStateNotes' :: OrgNoteTable
|
||||
, orgStateOptions :: ReaderOptions
|
||||
, orgStateParserContext :: ParserContext
|
||||
, orgStateTodoSequences :: [TodoSequence]
|
||||
}
|
||||
|
||||
data OrgParserLocal = OrgParserLocal { orgLocalQuoteContext :: QuoteContext }
|
||||
|
|
@ -133,12 +153,31 @@ defaultOrgParserState = OrgParserState
|
|||
, orgStateNotes' = []
|
||||
, orgStateOptions = def
|
||||
, orgStateParserContext = NullState
|
||||
, orgStateTodoSequences = []
|
||||
}
|
||||
|
||||
optionsToParserState :: ReaderOptions -> OrgParserState
|
||||
optionsToParserState opts =
|
||||
def { orgStateOptions = opts }
|
||||
|
||||
registerTodoSequence :: TodoSequence -> OrgParserState -> OrgParserState
|
||||
registerTodoSequence todoSeq st =
|
||||
let curSeqs = orgStateTodoSequences st
|
||||
in st{ orgStateTodoSequences = todoSeq : curSeqs }
|
||||
|
||||
-- | Get the current todo/done sequences. If no custom todo sequences have been
|
||||
-- defined, return a list containing just the default todo/done sequence.
|
||||
activeTodoSequences :: OrgParserState -> [TodoSequence]
|
||||
activeTodoSequences st =
|
||||
let curSeqs = orgStateTodoSequences st
|
||||
in if null curSeqs
|
||||
then [[ TodoMarker Todo "TODO" , TodoMarker Done "DONE" ]]
|
||||
else curSeqs
|
||||
|
||||
activeTodoMarkers :: OrgParserState -> TodoSequence
|
||||
activeTodoMarkers = concat . activeTodoSequences
|
||||
|
||||
|
||||
--
|
||||
-- Export Settings
|
||||
--
|
||||
|
|
|
|||
|
|
@ -693,139 +693,179 @@ tests =
|
|||
"Paragraph\n" =?>
|
||||
para "Paragraph"
|
||||
|
||||
, "First Level Header" =:
|
||||
"* Headline\n" =?>
|
||||
headerWith ("headline", [], []) 1 "Headline"
|
||||
, testGroup "headers" $
|
||||
[ "First Level Header" =:
|
||||
"* Headline\n" =?>
|
||||
headerWith ("headline", [], []) 1 "Headline"
|
||||
|
||||
, "Third Level Header" =:
|
||||
"*** Third Level Headline\n" =?>
|
||||
headerWith ("third-level-headline", [], [])
|
||||
3
|
||||
("Third" <> space <> "Level" <> space <> "Headline")
|
||||
, "Third Level Header" =:
|
||||
"*** Third Level Headline\n" =?>
|
||||
headerWith ("third-level-headline", [], [])
|
||||
3
|
||||
("Third" <> space <> "Level" <> space <> "Headline")
|
||||
|
||||
, "Compact Headers with Paragraph" =:
|
||||
unlines [ "* First Level"
|
||||
, "** Second Level"
|
||||
, " Text"
|
||||
] =?>
|
||||
mconcat [ headerWith ("first-level", [], [])
|
||||
1
|
||||
("First" <> space <> "Level")
|
||||
, headerWith ("second-level", [], [])
|
||||
2
|
||||
("Second" <> space <> "Level")
|
||||
, para "Text"
|
||||
]
|
||||
, "Compact Headers with Paragraph" =:
|
||||
unlines [ "* First Level"
|
||||
, "** Second Level"
|
||||
, " Text"
|
||||
] =?>
|
||||
mconcat [ headerWith ("first-level", [], [])
|
||||
1
|
||||
("First" <> space <> "Level")
|
||||
, headerWith ("second-level", [], [])
|
||||
2
|
||||
("Second" <> space <> "Level")
|
||||
, para "Text"
|
||||
]
|
||||
|
||||
, "Separated Headers with Paragraph" =:
|
||||
unlines [ "* First Level"
|
||||
, ""
|
||||
, "** Second Level"
|
||||
, ""
|
||||
, " Text"
|
||||
] =?>
|
||||
mconcat [ headerWith ("first-level", [], [])
|
||||
1
|
||||
("First" <> space <> "Level")
|
||||
, headerWith ("second-level", [], [])
|
||||
2
|
||||
("Second" <> space <> "Level")
|
||||
, para "Text"
|
||||
]
|
||||
, "Separated Headers with Paragraph" =:
|
||||
unlines [ "* First Level"
|
||||
, ""
|
||||
, "** Second Level"
|
||||
, ""
|
||||
, " Text"
|
||||
] =?>
|
||||
mconcat [ headerWith ("first-level", [], [])
|
||||
1
|
||||
("First" <> space <> "Level")
|
||||
, headerWith ("second-level", [], [])
|
||||
2
|
||||
("Second" <> space <> "Level")
|
||||
, para "Text"
|
||||
]
|
||||
|
||||
, "Headers not preceded by a blank line" =:
|
||||
unlines [ "** eat dinner"
|
||||
, "Spaghetti and meatballs tonight."
|
||||
, "** walk dog"
|
||||
] =?>
|
||||
mconcat [ headerWith ("eat-dinner", [], [])
|
||||
2
|
||||
("eat" <> space <> "dinner")
|
||||
, para $ spcSep [ "Spaghetti", "and", "meatballs", "tonight." ]
|
||||
, headerWith ("walk-dog", [], [])
|
||||
2
|
||||
("walk" <> space <> "dog")
|
||||
]
|
||||
, "Headers not preceded by a blank line" =:
|
||||
unlines [ "** eat dinner"
|
||||
, "Spaghetti and meatballs tonight."
|
||||
, "** walk dog"
|
||||
] =?>
|
||||
mconcat [ headerWith ("eat-dinner", [], [])
|
||||
2
|
||||
("eat" <> space <> "dinner")
|
||||
, para $ spcSep [ "Spaghetti", "and", "meatballs", "tonight." ]
|
||||
, headerWith ("walk-dog", [], [])
|
||||
2
|
||||
("walk" <> space <> "dog")
|
||||
]
|
||||
|
||||
, "Tagged headers" =:
|
||||
unlines [ "* Personal :PERSONAL:"
|
||||
, "** Call Mom :@PHONE:"
|
||||
, "** Call John :@PHONE:JOHN: "
|
||||
] =?>
|
||||
let tagSpan t = spanWith ("", ["tag"], [("data-tag-name", t)]) mempty
|
||||
in mconcat [ headerWith ("personal", [], [])
|
||||
1
|
||||
("Personal" <> tagSpan "PERSONAL")
|
||||
, headerWith ("call-mom", [], [])
|
||||
2
|
||||
("Call Mom" <> tagSpan "@PHONE")
|
||||
, headerWith ("call-john", [], [])
|
||||
2
|
||||
("Call John" <> tagSpan "@PHONE" <> tagSpan "JOHN")
|
||||
]
|
||||
, testGroup "Todo keywords"
|
||||
[ "Header with known todo keyword" =:
|
||||
"* TODO header" =?>
|
||||
let todoSpan = spanWith ("", ["todo", "TODO"], []) "TODO"
|
||||
in headerWith ("header", [], []) 1 (todoSpan <> space <> "header")
|
||||
|
||||
, "Untagged header containing colons" =:
|
||||
"* This: is not: tagged" =?>
|
||||
headerWith ("this-is-not-tagged", [], []) 1 "This: is not: tagged"
|
||||
, "Header marked as done" =:
|
||||
"* DONE header" =?>
|
||||
let todoSpan = spanWith ("", ["done", "DONE"], []) "DONE"
|
||||
in headerWith ("header", [], []) 1 (todoSpan <> space <> "header")
|
||||
|
||||
, "Header starting with strokeout text" =:
|
||||
unlines [ "foo"
|
||||
, ""
|
||||
, "* +thing+ other thing"
|
||||
] =?>
|
||||
mconcat [ para "foo"
|
||||
, headerWith ("thing-other-thing", [], [])
|
||||
1
|
||||
((strikeout "thing") <> " other thing")
|
||||
]
|
||||
, "Header with unknown todo keyword" =:
|
||||
"* WAITING header" =?>
|
||||
headerWith ("waiting-header", [], []) 1 "WAITING header"
|
||||
|
||||
, "Comment Trees" =:
|
||||
unlines [ "* COMMENT A comment tree"
|
||||
, " Not much going on here"
|
||||
, "** This will be dropped"
|
||||
, "* Comment tree above"
|
||||
] =?>
|
||||
headerWith ("comment-tree-above", [], []) 1 "Comment tree above"
|
||||
, "Custom todo keywords" =:
|
||||
unlines [ "#+TODO: WAITING CANCELLED"
|
||||
, "* WAITING compile"
|
||||
, "* CANCELLED lunch"
|
||||
] =?>
|
||||
let todoSpan = spanWith ("", ["todo", "WAITING"], []) "WAITING"
|
||||
doneSpan = spanWith ("", ["done", "CANCELLED"], []) "CANCELLED"
|
||||
in headerWith ("compile", [], []) 1 (todoSpan <> space <> "compile")
|
||||
<> headerWith ("lunch", [], []) 1 (doneSpan <> space <> "lunch")
|
||||
|
||||
, "Nothing but a COMMENT header" =:
|
||||
"* COMMENT Test" =?>
|
||||
(mempty::Blocks)
|
||||
, "Custom todo keywords with multiple done-states" =:
|
||||
unlines [ "#+TODO: WAITING | DONE CANCELLED "
|
||||
, "* WAITING compile"
|
||||
, "* CANCELLED lunch"
|
||||
, "* DONE todo-feature"
|
||||
] =?>
|
||||
let waiting = spanWith ("", ["todo", "WAITING"], []) "WAITING"
|
||||
cancelled = spanWith ("", ["done", "CANCELLED"], []) "CANCELLED"
|
||||
done = spanWith ("", ["done", "DONE"], []) "DONE"
|
||||
in headerWith ("compile", [], []) 1 (waiting <> space <> "compile")
|
||||
<> headerWith ("lunch", [], []) 1 (cancelled <> space <> "lunch")
|
||||
<> headerWith ("todo-feature", [], []) 1 (done <> space <> "todo-feature")
|
||||
]
|
||||
|
||||
, "Tree with :noexport:" =:
|
||||
unlines [ "* Should be ignored :archive:noexport:old:"
|
||||
, "** Old stuff"
|
||||
, " This is not going to be exported"
|
||||
] =?>
|
||||
(mempty::Blocks)
|
||||
, "Tagged headers" =:
|
||||
unlines [ "* Personal :PERSONAL:"
|
||||
, "** Call Mom :@PHONE:"
|
||||
, "** Call John :@PHONE:JOHN: "
|
||||
] =?>
|
||||
let tagSpan t = spanWith ("", ["tag"], [("data-tag-name", t)]) mempty
|
||||
in mconcat [ headerWith ("personal", [], [])
|
||||
1
|
||||
("Personal" <> tagSpan "PERSONAL")
|
||||
, headerWith ("call-mom", [], [])
|
||||
2
|
||||
("Call Mom" <> tagSpan "@PHONE")
|
||||
, headerWith ("call-john", [], [])
|
||||
2
|
||||
("Call John" <> tagSpan "@PHONE" <> tagSpan "JOHN")
|
||||
]
|
||||
|
||||
, "Subtree with :noexport:" =:
|
||||
unlines [ "* Exported"
|
||||
, "** This isn't exported :noexport:"
|
||||
, "*** This neither"
|
||||
, "** But this is"
|
||||
] =?>
|
||||
mconcat [ headerWith ("exported", [], []) 1 "Exported"
|
||||
, headerWith ("but-this-is", [], []) 2 "But this is"
|
||||
]
|
||||
, "Untagged header containing colons" =:
|
||||
"* This: is not: tagged" =?>
|
||||
headerWith ("this-is-not-tagged", [], []) 1 "This: is not: tagged"
|
||||
|
||||
, "Preferences are treated as header attributes" =:
|
||||
unlines [ "* foo"
|
||||
, " :PROPERTIES:"
|
||||
, " :custom_id: fubar"
|
||||
, " :bar: baz"
|
||||
, " :END:"
|
||||
] =?>
|
||||
headerWith ("fubar", [], [("bar", "baz")]) 1 "foo"
|
||||
, "Header starting with strokeout text" =:
|
||||
unlines [ "foo"
|
||||
, ""
|
||||
, "* +thing+ other thing"
|
||||
] =?>
|
||||
mconcat [ para "foo"
|
||||
, headerWith ("thing-other-thing", [], [])
|
||||
1
|
||||
((strikeout "thing") <> " other thing")
|
||||
]
|
||||
|
||||
, "Comment Trees" =:
|
||||
unlines [ "* COMMENT A comment tree"
|
||||
, " Not much going on here"
|
||||
, "** This will be dropped"
|
||||
, "* Comment tree above"
|
||||
] =?>
|
||||
headerWith ("comment-tree-above", [], []) 1 "Comment tree above"
|
||||
|
||||
, "Nothing but a COMMENT header" =:
|
||||
"* COMMENT Test" =?>
|
||||
(mempty::Blocks)
|
||||
|
||||
, "Tree with :noexport:" =:
|
||||
unlines [ "* Should be ignored :archive:noexport:old:"
|
||||
, "** Old stuff"
|
||||
, " This is not going to be exported"
|
||||
] =?>
|
||||
(mempty::Blocks)
|
||||
|
||||
, "Subtree with :noexport:" =:
|
||||
unlines [ "* Exported"
|
||||
, "** This isn't exported :noexport:"
|
||||
, "*** This neither"
|
||||
, "** But this is"
|
||||
] =?>
|
||||
mconcat [ headerWith ("exported", [], []) 1 "Exported"
|
||||
, headerWith ("but-this-is", [], []) 2 "But this is"
|
||||
]
|
||||
|
||||
, "Preferences are treated as header attributes" =:
|
||||
unlines [ "* foo"
|
||||
, " :PROPERTIES:"
|
||||
, " :custom_id: fubar"
|
||||
, " :bar: baz"
|
||||
, " :END:"
|
||||
] =?>
|
||||
headerWith ("fubar", [], [("bar", "baz")]) 1 "foo"
|
||||
|
||||
|
||||
, "Headers marked with a unnumbered property get a class of the same name" =:
|
||||
unlines [ "* Not numbered"
|
||||
, " :PROPERTIES:"
|
||||
, " :UNNUMBERED: t"
|
||||
, " :END:"
|
||||
] =?>
|
||||
headerWith ("not-numbered", ["unnumbered"], []) 1 "Not numbered"
|
||||
|
||||
, "Headers marked with a unnumbered property get a class of the same name" =:
|
||||
unlines [ "* Not numbered"
|
||||
, " :PROPERTIES:"
|
||||
, " :UNNUMBERED: t"
|
||||
, " :END:"
|
||||
] =?>
|
||||
headerWith ("not-numbered", ["unnumbered"], []) 1 "Not numbered"
|
||||
]
|
||||
, "Paragraph starting with an asterisk" =:
|
||||
"*five" =?>
|
||||
para "*five"
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue