d518277 · typeable/pandoc

git.iko.soy/typeable/pandoc

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

commitd5182778c45704b0a2d5d283a7fca5104588af81 authorAlbert Krewinkel <albert@zeitkraut.de> dateSun 30 Oct 2016, 10:27 (10 years ago) parentd2bc983

4 files changed+263−130

compare with master

unifiedsplit

src/Text/Pandoc/Readers/Org/Blocks.hs+20−1 src/Text/Pandoc/Readers/Org/Meta.hs+39−4 src/Text/Pandoc/Readers/Org/ParserState.hs+39 tests/Tests/Readers/Org.hs+165−125

src/Text/Pandoc/Readers/Org/Blocks.hs+20−1

@@ -90,6 +90,7 @@ type Properties = [(PropertyKey, PropertyValue)]

9090-- | Org mode headline (i.e. a document subtree).

9191data Headline = Headline

9292 { headlineLevel :: Int

93+ , headlineTodoMarker :: Maybe TodoMarker

9394 , headlineText :: Inlines

9495 , headlineTags :: [Tag]

9596 , headlineProperties :: Properties

@@ -107,6 +108,7 @@ headline :: Int -> OrgParser (F Headline)

107108headline lvl = try $ do

108109 level <- headerStart

109110 guard (lvl <= level)

111+ todoKw <- optionMaybe todoKeyword

110112 title <- trimInlinesF . mconcat <$> manyTill inline endOfTitle

111113 tags <- option [] headerTags

112114 newline

@@ -119,6 +121,7 @@ headline lvl = try $ do

119121 children' <- sequence children

120122 return $ Headline

121123 { headlineLevel = level

124+ , headlineTodoMarker = todoKw

122125 , headlineText = title'

123126 , headlineTags = tags

124127 , headlineProperties = properties

@@ -193,11 +196,27 @@ headlineToHeaderWithContents hdln@(Headline {..}) = do

193196

194197headlineToHeader :: Headline -> OrgParser Blocks

195198headlineToHeader (Headline {..}) = do

196− let text = tagTitle headlineText headlineTags

199+ let todoText = case headlineTodoMarker of

200+ Just kw -> todoKeywordToInlines kw <> B.space

201+ Nothing -> mempty

202+ let text = tagTitle (todoText <> headlineText) headlineTags

197203 let propAttr = propertiesToAttr headlineProperties

198204 attr <- registerHeader propAttr headlineText

199205 return $ B.headerWith attr headlineLevel text

200206

207+todoKeyword :: OrgParser TodoMarker

208+todoKeyword = try $ do

209+ taskStates <- activeTodoMarkers <$> getState

210+ let kwParser tdm = try $ (tdm <$ string (todoMarkerName tdm) <* spaceChar)

211+ choice (map kwParser taskStates)

212+

213+todoKeywordToInlines :: TodoMarker -> Inlines

214+todoKeywordToInlines tdm =

215+ let todoText = todoMarkerName tdm

216+ todoState = map toLower . show $ todoMarkerState tdm

217+ classes = [todoState, todoText]

218+ in B.spanWith (mempty, classes, mempty) (B.str todoText)

219+

201220propertiesToAttr :: Properties -> Attr

202221propertiesToAttr properties =

203222 let

src/Text/Pandoc/Readers/Org/Meta.hs+39−4

@@ -42,11 +42,11 @@ import qualified Text.Pandoc.Builder as B

4242import Text.Pandoc.Builder ( Blocks, Inlines )

4343import Text.Pandoc.Definition

4444

45−import Control.Monad ( mzero )

45+import Control.Monad ( mzero, void )

4646import Data.Char ( toLower )

4747import Data.List ( intersperse )

4848import qualified Data.Map as M

49−import Data.Monoid ((<>))

49+import Data.Monoid ( (<>) )

5050import Network.HTTP ( urlEncode )

5151

5252-- | Returns the current meta, respecting export options.

@@ -144,8 +144,11 @@ optionLine :: OrgParser ()

144144optionLine = try $ do

145145 key <- metaKey

146146 case key of

147− "link" -> parseLinkFormat >>= uncurry addLinkFormat

148− "options" -> exportSettings

147+ "link" -> parseLinkFormat >>= uncurry addLinkFormat

148+ "options" -> exportSettings

149+ "todo" -> todoSequence >>= updateState . registerTodoSequence

150+ "seq_todo" -> todoSequence >>= updateState . registerTodoSequence

151+ "typ_todo" -> todoSequence >>= updateState . registerTodoSequence

149152 _ -> mzero

150153

151154addLinkFormat :: String

@@ -179,3 +182,35 @@ parseFormat = try $ do

179182

180183inlinesTillNewline :: OrgParser (F Inlines)

181184inlinesTillNewline = trimInlinesF . mconcat <$> manyTill inline newline

185+

186+--

187+-- ToDo Sequences and Keywords

188+--

189+todoSequence :: OrgParser TodoSequence

190+todoSequence = try $ do

191+ todoKws <- todoKeywords

192+ doneKws <- optionMaybe $ todoDoneSep *> todoKeywords

193+ newline

194+ -- There must be at least one DONE keyword. The last TODO keyword is taken if

195+ -- necessary.

196+ case doneKws of

197+ Just done -> return $ keywordsToSequence todoKws done

198+ Nothing -> case reverse todoKws of

199+ [] -> mzero -- no keywords present

200+ (x:xs) -> return $ keywordsToSequence (reverse xs) [x]

201+

202+ where

203+ todoKeywords :: OrgParser [String]

204+ todoKeywords = try $

205+ let keyword = many1 nonspaceChar <* skipSpaces

206+ endOfKeywords = todoDoneSep <|> void newline

207+ in manyTill keyword (lookAhead endOfKeywords)

208+

209+ todoDoneSep :: OrgParser ()

210+ todoDoneSep = void . try $ skipSpaces *> char '|' <* skipSpaces1

211+

212+ keywordsToSequence :: [String] -> [String] -> TodoSequence

213+ keywordsToSequence todo done =

214+ let todoMarkers = map (TodoMarker Todo) todo

215+ doneMarkers = map (TodoMarker Done) done

216+ in todoMarkers ++ doneMarkers

src/Text/Pandoc/Readers/Org/ParserState.hs+39

@@ -34,6 +34,11 @@ module Text.Pandoc.Readers.Org.ParserState

3434 , OrgNoteRecord

3535 , HasReaderOptions (..)

3636 , HasQuoteContext (..)

37+ , TodoMarker (..)

38+ , TodoSequence

39+ , TodoState (..)

40+ , activeTodoMarkers

41+ , registerTodoSequence

3742 , F(..)

3843 , askF

3944 , asksF

@@ -72,6 +77,20 @@ type OrgNoteTable = [OrgNoteRecord]

7277-- link-type, the corresponding function transforms the given link string.

7378type OrgLinkFormatters = M.Map String (String -> String)

7479

80+-- | The states in which a todo item can be

81+data TodoState = Todo | Done

82+ deriving (Eq, Ord, Show)

83+

84+-- | A ToDo keyword like @TODO@ or @DONE@.

85+data TodoMarker = TodoMarker

86+ { todoMarkerState :: TodoState

87+ , todoMarkerName :: String

88+ }

89+ deriving (Show, Eq)

90+

91+-- | Collection of todo markers in the order in which items should progress

92+type TodoSequence = [TodoMarker]

93+

7594-- | Org-mode parser state

7695data OrgParserState = OrgParserState

7796 { orgStateAnchorIds :: [String]

@@ -88,6 +107,7 @@ data OrgParserState = OrgParserState

88107 , orgStateNotes' :: OrgNoteTable

89108 , orgStateOptions :: ReaderOptions

90109 , orgStateParserContext :: ParserContext

110+ , orgStateTodoSequences :: [TodoSequence]

91111 }

92112

93113data OrgParserLocal = OrgParserLocal { orgLocalQuoteContext :: QuoteContext }

@@ -133,12 +153,31 @@ defaultOrgParserState = OrgParserState

133153 , orgStateNotes' = []

134154 , orgStateOptions = def

135155 , orgStateParserContext = NullState

156+ , orgStateTodoSequences = []

136157 }

137158

138159optionsToParserState :: ReaderOptions -> OrgParserState

139160optionsToParserState opts =

140161 def { orgStateOptions = opts }

141162

163+registerTodoSequence :: TodoSequence -> OrgParserState -> OrgParserState

164+registerTodoSequence todoSeq st =

165+ let curSeqs = orgStateTodoSequences st

166+ in st{ orgStateTodoSequences = todoSeq : curSeqs }

167+

168+-- | Get the current todo/done sequences. If no custom todo sequences have been

169+-- defined, return a list containing just the default todo/done sequence.

170+activeTodoSequences :: OrgParserState -> [TodoSequence]

171+activeTodoSequences st =

172+ let curSeqs = orgStateTodoSequences st

173+ in if null curSeqs

174+ then [[ TodoMarker Todo "TODO" , TodoMarker Done "DONE" ]]

175+ else curSeqs

176+

177+activeTodoMarkers :: OrgParserState -> TodoSequence

178+activeTodoMarkers = concat . activeTodoSequences

179+

180+

142181--

143182-- Export Settings

144183--

tests/Tests/Readers/Org.hs+165−125

@@ -693,139 +693,179 @@ tests =

693693 "Paragraph\n" =?>

694694 para "Paragraph"

695695

696− , "First Level Header" =:

697− "* Headline\n" =?>

698− headerWith ("headline", [], []) 1 "Headline"

699−

700− , "Third Level Header" =:

701− "*** Third Level Headline\n" =?>

702− headerWith ("third-level-headline", [], [])

703− 3

704− ("Third" <> space <> "Level" <> space <> "Headline")

705−

706− , "Compact Headers with Paragraph" =:

707− unlines [ "* First Level"

708− , "** Second Level"

709− , " Text"

710− ] =?>

711− mconcat [ headerWith ("first-level", [], [])

712− 1

713− ("First" <> space <> "Level")

714− , headerWith ("second-level", [], [])

715− 2

716− ("Second" <> space <> "Level")

717− , para "Text"

718− ]

719−

720− , "Separated Headers with Paragraph" =:

721− unlines [ "* First Level"

722− , ""

723− , "** Second Level"

724− , ""

725− , " Text"

726− ] =?>

727− mconcat [ headerWith ("first-level", [], [])

728− 1

729− ("First" <> space <> "Level")

730− , headerWith ("second-level", [], [])

731− 2

732− ("Second" <> space <> "Level")

733− , para "Text"

734− ]

735−

736− , "Headers not preceded by a blank line" =:

737− unlines [ "** eat dinner"

738− , "Spaghetti and meatballs tonight."

739− , "** walk dog"

740− ] =?>

741− mconcat [ headerWith ("eat-dinner", [], [])

742− 2

743− ("eat" <> space <> "dinner")

744− , para $ spcSep [ "Spaghetti", "and", "meatballs", "tonight." ]

745− , headerWith ("walk-dog", [], [])

746− 2

747− ("walk" <> space <> "dog")

748− ]

749−

750− , "Tagged headers" =:

751− unlines [ "* Personal :PERSONAL:"

752− , "** Call Mom :@PHONE:"

753− , "** Call John :@PHONE:JOHN: "

754− ] =?>

755− let tagSpan t = spanWith ("", ["tag"], [("data-tag-name", t)]) mempty

756− in mconcat [ headerWith ("personal", [], [])

757− 1

758− ("Personal" <> tagSpan "PERSONAL")

759− , headerWith ("call-mom", [], [])

760− 2

761− ("Call Mom" <> tagSpan "@PHONE")

762− , headerWith ("call-john", [], [])

763− 2

764− ("Call John" <> tagSpan "@PHONE" <> tagSpan "JOHN")

765− ]

766−

767− , "Untagged header containing colons" =:

768− "* This: is not: tagged" =?>

769− headerWith ("this-is-not-tagged", [], []) 1 "This: is not: tagged"

770−

771− , "Header starting with strokeout text" =:

772− unlines [ "foo"

773− , ""

774− , "* +thing+ other thing"

775− ] =?>

776− mconcat [ para "foo"

777− , headerWith ("thing-other-thing", [], [])

778− 1

779− ((strikeout "thing") <> " other thing")

780− ]

696+ , testGroup "headers" $

697+ [ "First Level Header" =:

698+ "* Headline\n" =?>

699+ headerWith ("headline", [], []) 1 "Headline"

700+

701+ , "Third Level Header" =:

702+ "*** Third Level Headline\n" =?>

703+ headerWith ("third-level-headline", [], [])

704+ 3

705+ ("Third" <> space <> "Level" <> space <> "Headline")

706+

707+ , "Compact Headers with Paragraph" =:

708+ unlines [ "* First Level"

709+ , "** Second Level"

710+ , " Text"

711+ ] =?>

712+ mconcat [ headerWith ("first-level", [], [])

713+ 1

714+ ("First" <> space <> "Level")

715+ , headerWith ("second-level", [], [])

716+ 2

717+ ("Second" <> space <> "Level")

718+ , para "Text"

719+ ]

720+

721+ , "Separated Headers with Paragraph" =:

722+ unlines [ "* First Level"

723+ , ""

724+ , "** Second Level"

725+ , ""

726+ , " Text"

727+ ] =?>

728+ mconcat [ headerWith ("first-level", [], [])

729+ 1

730+ ("First" <> space <> "Level")

731+ , headerWith ("second-level", [], [])

732+ 2

733+ ("Second" <> space <> "Level")

734+ , para "Text"

735+ ]

736+

737+ , "Headers not preceded by a blank line" =:

738+ unlines [ "** eat dinner"

739+ , "Spaghetti and meatballs tonight."

740+ , "** walk dog"

741+ ] =?>

742+ mconcat [ headerWith ("eat-dinner", [], [])

743+ 2

744+ ("eat" <> space <> "dinner")

745+ , para $ spcSep [ "Spaghetti", "and", "meatballs", "tonight." ]

746+ , headerWith ("walk-dog", [], [])

747+ 2

748+ ("walk" <> space <> "dog")

749+ ]

750+

751+ , testGroup "Todo keywords"

752+ [ "Header with known todo keyword" =:

753+ "* TODO header" =?>

754+ let todoSpan = spanWith ("", ["todo", "TODO"], []) "TODO"

755+ in headerWith ("header", [], []) 1 (todoSpan <> space <> "header")

756+

757+ , "Header marked as done" =:

758+ "* DONE header" =?>

759+ let todoSpan = spanWith ("", ["done", "DONE"], []) "DONE"

760+ in headerWith ("header", [], []) 1 (todoSpan <> space <> "header")

761+

762+ , "Header with unknown todo keyword" =:

763+ "* WAITING header" =?>

764+ headerWith ("waiting-header", [], []) 1 "WAITING header"

765+

766+ , "Custom todo keywords" =:

767+ unlines [ "#+TODO: WAITING CANCELLED"

768+ , "* WAITING compile"

769+ , "* CANCELLED lunch"

770+ ] =?>

771+ let todoSpan = spanWith ("", ["todo", "WAITING"], []) "WAITING"

772+ doneSpan = spanWith ("", ["done", "CANCELLED"], []) "CANCELLED"

773+ in headerWith ("compile", [], []) 1 (todoSpan <> space <> "compile")

774+ <> headerWith ("lunch", [], []) 1 (doneSpan <> space <> "lunch")

775+

776+ , "Custom todo keywords with multiple done-states" =:

777+ unlines [ "#+TODO: WAITING | DONE CANCELLED "

778+ , "* WAITING compile"

779+ , "* CANCELLED lunch"

780+ , "* DONE todo-feature"

781+ ] =?>

782+ let waiting = spanWith ("", ["todo", "WAITING"], []) "WAITING"

783+ cancelled = spanWith ("", ["done", "CANCELLED"], []) "CANCELLED"

784+ done = spanWith ("", ["done", "DONE"], []) "DONE"

785+ in headerWith ("compile", [], []) 1 (waiting <> space <> "compile")

786+ <> headerWith ("lunch", [], []) 1 (cancelled <> space <> "lunch")

787+ <> headerWith ("todo-feature", [], []) 1 (done <> space <> "todo-feature")

788+ ]

781789

782− , "Comment Trees" =:

783− unlines [ "* COMMENT A comment tree"

784− , " Not much going on here"

785− , "** This will be dropped"

786− , "* Comment tree above"

787− ] =?>

788− headerWith ("comment-tree-above", [], []) 1 "Comment tree above"

790+ , "Tagged headers" =:

791+ unlines [ "* Personal :PERSONAL:"

792+ , "** Call Mom :@PHONE:"

793+ , "** Call John :@PHONE:JOHN: "

794+ ] =?>

795+ let tagSpan t = spanWith ("", ["tag"], [("data-tag-name", t)]) mempty

796+ in mconcat [ headerWith ("personal", [], [])

797+ 1

798+ ("Personal" <> tagSpan "PERSONAL")

799+ , headerWith ("call-mom", [], [])

800+ 2

801+ ("Call Mom" <> tagSpan "@PHONE")

802+ , headerWith ("call-john", [], [])

803+ 2

804+ ("Call John" <> tagSpan "@PHONE" <> tagSpan "JOHN")

805+ ]

789806

790− , "Nothing but a COMMENT header" =:

791− "* COMMENT Test" =?>

792− (mempty::Blocks)

807+ , "Untagged header containing colons" =:

808+ "* This: is not: tagged" =?>

809+ headerWith ("this-is-not-tagged", [], []) 1 "This: is not: tagged"

793810

794− , "Tree with :noexport:" =:

795− unlines [ "* Should be ignored :archive:noexport:old:"

796− , "** Old stuff"

797− , " This is not going to be exported"

798− ] =?>

799− (mempty::Blocks)

811+ , "Header starting with strokeout text" =:

812+ unlines [ "foo"

813+ , ""

814+ , "* +thing+ other thing"

815+ ] =?>

816+ mconcat [ para "foo"

817+ , headerWith ("thing-other-thing", [], [])

818+ 1

819+ ((strikeout "thing") <> " other thing")

820+ ]

821+

822+ , "Comment Trees" =:

823+ unlines [ "* COMMENT A comment tree"

824+ , " Not much going on here"

825+ , "** This will be dropped"

826+ , "* Comment tree above"

827+ ] =?>

828+ headerWith ("comment-tree-above", [], []) 1 "Comment tree above"

800829

801− , "Subtree with :noexport:" =:

802− unlines [ "* Exported"

803− , "** This isn't exported :noexport:"

804− , "*** This neither"

805− , "** But this is"

806− ] =?>

807− mconcat [ headerWith ("exported", [], []) 1 "Exported"

808− , headerWith ("but-this-is", [], []) 2 "But this is"

809− ]

830+ , "Nothing but a COMMENT header" =:

831+ "* COMMENT Test" =?>

832+ (mempty::Blocks)

810833

811− , "Preferences are treated as header attributes" =:

812− unlines [ "* foo"

813− , " :PROPERTIES:"

814− , " :custom_id: fubar"

815− , " :bar: baz"

816− , " :END:"

817− ] =?>

818− headerWith ("fubar", [], [("bar", "baz")]) 1 "foo"

834+ , "Tree with :noexport:" =:

835+ unlines [ "* Should be ignored :archive:noexport:old:"

836+ , "** Old stuff"

837+ , " This is not going to be exported"

838+ ] =?>

839+ (mempty::Blocks)

819840

841+ , "Subtree with :noexport:" =:

842+ unlines [ "* Exported"

843+ , "** This isn't exported :noexport:"

844+ , "*** This neither"

845+ , "** But this is"

846+ ] =?>

847+ mconcat [ headerWith ("exported", [], []) 1 "Exported"

848+ , headerWith ("but-this-is", [], []) 2 "But this is"

849+ ]

850+

851+ , "Preferences are treated as header attributes" =:

852+ unlines [ "* foo"

853+ , " :PROPERTIES:"

854+ , " :custom_id: fubar"

855+ , " :bar: baz"

856+ , " :END:"

857+ ] =?>

858+ headerWith ("fubar", [], [("bar", "baz")]) 1 "foo"

820859

821− , "Headers marked with a unnumbered property get a class of the same name" =:

822− unlines [ "* Not numbered"

823− , " :PROPERTIES:"

824− , " :UNNUMBERED: t"

825− , " :END:"

826− ] =?>

827− headerWith ("not-numbered", ["unnumbered"], []) 1 "Not numbered"

828860

861+ , "Headers marked with a unnumbered property get a class of the same name" =:

862+ unlines [ "* Not numbered"

863+ , " :PROPERTIES:"

864+ , " :UNNUMBERED: t"

865+ , " :END:"

866+ ] =?>

867+ headerWith ("not-numbered", ["unnumbered"], []) 1 "Not numbered"

868+ ]

829869 , "Paragraph starting with an asterisk" =:

830870 "*five" =?>

831871 para "*five"