d518277 · typeable/pandoc

git.iko.soy/typeable/pandoc

on master help sign in

Org reader: add support for todo-markers

d518277Albert Krewinkel10 years ago

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

compare with master

unifiedsplit

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

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

91data Headline = Headline

92 { headlineLevel :: Int

93+ , headlineTodoMarker :: Maybe TodoMarker

93 , headlineText :: Inlines

94 , headlineText :: Inlines

94 , headlineTags :: [Tag]

95 , headlineTags :: [Tag]

95 , headlineProperties :: Properties

96 , headlineProperties :: Properties

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

107headline lvl = try $ do

108headline lvl = try $ do

108 level <- headerStart

109 level <- headerStart

109 guard (lvl <= level)

110 guard (lvl <= level)

111+ todoKw <- optionMaybe todoKeyword

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

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

111 tags <- option [] headerTags

113 tags <- option [] headerTags

112 newline

114 newline

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

119 children' <- sequence children

121 children' <- sequence children

120 return $ Headline

122 return $ Headline

121 { headlineLevel = level

123 { headlineLevel = level

124+ , headlineTodoMarker = todoKw

122 , headlineText = title'

125 , headlineText = title'

123 , headlineTags = tags

126 , headlineTags = tags

124 , headlineProperties = properties

127 , headlineProperties = properties

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

193

196

194headlineToHeader :: Headline -> OrgParser Blocks

197headlineToHeader :: Headline -> OrgParser Blocks

195headlineToHeader (Headline {..}) = do

198headlineToHeader (Headline {..}) = do

199+ let todoText = case headlineTodoMarker of

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

201+ Nothing -> mempty

196− let text = tagTitle headlineText headlineTags

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

197 let propAttr = propertiesToAttr headlineProperties

203 let propAttr = propertiesToAttr headlineProperties

198 attr <- registerHeader propAttr headlineText

204 attr <- registerHeader propAttr headlineText

199 return $ B.headerWith attr headlineLevel text

205 return $ B.headerWith attr headlineLevel text

200

206

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+

201propertiesToAttr :: Properties -> Attr

220propertiesToAttr :: Properties -> Attr

202propertiesToAttr properties =

221propertiesToAttr properties =

203 let

222 let

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

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

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

43import Text.Pandoc.Definition

45−import Control.Monad ( mzero )

45+import Control.Monad ( mzero, void )

46import Data.Char ( toLower )

47import Data.List ( intersperse )

48import qualified Data.Map as M

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

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

50import Network.HTTP ( urlEncode )

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

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

144optionLine = try $ do

145 key <- metaKey

146 case key of

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

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

148− "options" -> exportSettings

148+ "options" -> exportSettings

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

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

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

149 _ -> mzero

152 _ -> mzero

150

153

151addLinkFormat :: String

154addLinkFormat :: String

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

179

182

180inlinesTillNewline :: OrgParser (F Inlines)

183inlinesTillNewline :: OrgParser (F Inlines)

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

184inlinesTillNewline = 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

34 , OrgNoteRecord

35 , HasReaderOptions (..)

36 , HasQuoteContext (..)

37+ , TodoMarker (..)

38+ , TodoSequence

39+ , TodoState (..)

40+ , activeTodoMarkers

41+ , registerTodoSequence

37 , F(..)

42 , F(..)

38 , askF

43 , askF

39 , asksF

44 , asksF

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

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

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

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

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

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+

75-- | Org-mode parser state

94-- | Org-mode parser state

76data OrgParserState = OrgParserState

95data OrgParserState = OrgParserState

77 { orgStateAnchorIds :: [String]

96 { orgStateAnchorIds :: [String]

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

88 , orgStateNotes' :: OrgNoteTable

107 , orgStateNotes' :: OrgNoteTable

89 , orgStateOptions :: ReaderOptions

108 , orgStateOptions :: ReaderOptions

90 , orgStateParserContext :: ParserContext

109 , orgStateParserContext :: ParserContext

110+ , orgStateTodoSequences :: [TodoSequence]

91 }

111 }

112

93data OrgParserLocal = OrgParserLocal { orgLocalQuoteContext :: QuoteContext }

113data OrgParserLocal = OrgParserLocal { orgLocalQuoteContext :: QuoteContext }

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

133 , orgStateNotes' = []

153 , orgStateNotes' = []

134 , orgStateOptions = def

154 , orgStateOptions = def

135 , orgStateParserContext = NullState

155 , orgStateParserContext = NullState

156+ , orgStateTodoSequences = []

136 }

157 }

137

158

138optionsToParserState :: ReaderOptions -> OrgParserState

159optionsToParserState :: ReaderOptions -> OrgParserState

139optionsToParserState opts =

160optionsToParserState opts =

140 def { orgStateOptions = opts }

161 def { orgStateOptions = opts }

141

162

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+

142--

181--

143-- Export Settings

182-- Export Settings

144--

183--

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

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

693 "Paragraph\n" =?>

694 para "Paragraph"

695

696+ , testGroup "headers" $

696− , "First Level Header" =:

697+ [ "First Level Header" =:

697− "* Headline\n" =?>

698+ "* Headline\n" =?>

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

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

699−

700+

700− , "Third Level Header" =:

701+ , "Third Level Header" =:

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

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

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

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

703− 3

704+ 3

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

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

705−

706+

706− , "Compact Headers with Paragraph" =:

707+ , "Compact Headers with Paragraph" =:

707− unlines [ "* First Level"

708+ unlines [ "* First Level"

708− , "** Second Level"

709+ , "** Second Level"

709− , " Text"

710+ , " Text"

710− ] =?>

711+ ] =?>

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

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

712− 1

713+ 1

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

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

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

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

715− 2

716+ 2

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

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

717− , para "Text"

718+ , para "Text"

718− ]

719+ ]

719−

720+

720− , "Separated Headers with Paragraph" =:

721+ , "Separated Headers with Paragraph" =:

721− unlines [ "* First Level"

722+ unlines [ "* First Level"

722− , ""

723+ , ""

723− , "** Second Level"

724+ , "** Second Level"

724− , ""

725+ , ""

725− , " Text"

726+ , " Text"

726− ] =?>

727+ ] =?>

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

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

728− 1

729+ 1

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

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

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

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

731− 2

732+ 2

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

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

733− , para "Text"

734+ , para "Text"

734− ]

735+ ]

735−

736+

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

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

737− unlines [ "** eat dinner"

738+ unlines [ "** eat dinner"

738− , "Spaghetti and meatballs tonight."

739+ , "Spaghetti and meatballs tonight."

739− , "** walk dog"

740+ , "** walk dog"

740− ] =?>

741+ ] =?>

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

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

742− 2

743+ 2

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

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

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

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

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

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

746− 2

747+ 2

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

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

748− ]

749+ ]

749−

750+

750− , "Tagged headers" =:

751+ , testGroup "Todo keywords"

751− unlines [ "* Personal :PERSONAL:"

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

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

753+ "* TODO header" =?>

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

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

754− ] =?>

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

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

756+

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

757+ , "Header marked as done" =:

757− 1

758+ "* DONE header" =?>

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

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

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

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

760− 2

761+

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

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

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

763+ "* WAITING header" =?>

763− 2

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

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

765+

765− ]

766+ , "Custom todo keywords" =:

766−

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

767− , "Untagged header containing colons" =:

768+ , "* WAITING compile"

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

769+ , "* CANCELLED lunch"

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

770+ ] =?>

770−

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

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

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

772− unlines [ "foo"

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

773− , ""

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

774− , "* +thing+ other thing"

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"

775− ] =?>

781+ ] =?>

776− mconcat [ para "foo"

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

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

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

778− 1

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

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

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

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

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

780− ]

788+ ]

781

789

782− , "Comment Trees" =:

790+ , "Tagged headers" =:

783− unlines [ "* COMMENT A comment tree"

791+ unlines [ "* Personal :PERSONAL:"

784− , " Not much going on here"

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

785− , "** This will be dropped"

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

786− , "* Comment tree above"

787− ] =?>

794+ ] =?>

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

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+ ]

789

806

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

807+ , "Untagged header containing colons" =:

791− "* COMMENT Test" =?>

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

792− (mempty::Blocks)

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

793

810

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

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

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

812+ unlines [ "foo"

796− , "** Old stuff"

813+ , ""

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

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"

798− ] =?>

827+ ] =?>

799− (mempty::Blocks)

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

800

829

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

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

802− unlines [ "* Exported"

831+ "* COMMENT Test" =?>

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

832+ (mempty::Blocks)

804− , "*** This neither"

805− , "** But this is"

806− ] =?>

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

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

809− ]

810

833

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

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

812− unlines [ "* foo"

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

813− , " :PROPERTIES:"

836+ , "** Old stuff"

814− , " :custom_id: fubar"

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

815− , " :bar: baz"

816− , " :END:"

817− ] =?>

838+ ] =?>

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

839+ (mempty::Blocks)

819

840

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"

820

859

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"

828

860

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+ ]

829 , "Paragraph starting with an asterisk" =:

869 , "Paragraph starting with an asterisk" =:

830 "*five" =?>

870 "*five" =?>

831 para "*five"

871 para "*five"