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`).

3 files changed, 98 insertions, 5 deletions

diff --git a/src/Text/Pandoc/Readers/Org/Blocks.hs b/src/Text/Pandoc/Readers/Org/Blocks.hs
index 61978f79f..ead600ccc 100644
--- a/src/Text/Pandoc/Readers/Org/Blocks.hs
+++ b/src/Text/Pandoc/Readers/Org/Blocks.hs
@@ -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
diff --git a/src/Text/Pandoc/Readers/Org/Meta.hs b/src/Text/Pandoc/Readers/Org/Meta.hs
index ea088bfdb..bbbb216a0 100644
--- a/src/Text/Pandoc/Readers/Org/Meta.hs
+++ b/src/Text/Pandoc/Readers/Org/Meta.hs
@@ -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
diff --git a/src/Text/Pandoc/Readers/Org/ParserState.hs b/src/Text/Pandoc/Readers/Org/ParserState.hs
index 84dbe9d33..ef5f89461 100644
--- a/src/Text/Pandoc/Readers/Org/ParserState.hs
+++ b/src/Text/Pandoc/Readers/Org/ParserState.hs
@@ -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
 --