diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,26 @@ # Changelog +## Unreleased + +This release sees the extension of this library to understand heading +timestamps, TODOs, priorities, and `PROPERTIES` drawers. + +#### Added + +- A number of new timestamp types. +- `Ord` instances for every type. +- Functions `allDocTags` and `allSectionTags` for extracting unique `Set`s of + recursive heading tags. + +#### Changed + +- **Breaking:** `Section` has several new fields involving timestamps and properties. +- **Breaking:** The `Tags` variant has been removed from the `Words` type. + +#### Fixed + +- Heading tags are properly parsed. + ## 1.1.1 (2021-04-04) #### Fixed diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Colin Woodbury (c) 2020 +Copyright Colin Woodbury (c) 2020 - 2021 All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -8,11 +8,49 @@ - File metadata like [In-buffer Settings](https://orgmode.org/manual/In_002dbuffer-Settings.html#In_002dbuffer-Settings) appears at the top of the file. +- Special timestamps like `DEADLINE` always appear in the order `CLOSED`, + `DEADLINE`, then `SCHEDULED` if present together. +- If there are both a special timestamp and a regular timestamp present, the + regular timestamp must appear on the next line (this is how Emacs itself + inserts them). -## Unimplemented +## Specification Coverage -The following don't parse as of yet: +Basic styling: -- Table Formulas -- Anything involving the TODO system or clocking-in -- `:PROPERTIES:` +| Feature | Parses? | +|-----------------------|---------| +| Bold / Italics / etc. | Yes | +| URLs / Images | Yes | +| Lists | Yes | + +Headings: + +| Feature | Parses? | +|--------------|---------| +| Nesting | Yes | +| `TODO` | Yes | +| Priorities | Yes | +| Tags | Yes | +| Timestamps | Yes | +| `PROPERTIES` | Yes | + +Tables: + +| Feature | Parses? | +|------------|---------| +| Basic | Yes | +| Formulas | **No** | +| Properties | **No** | + +Blocks: + +| Feature | Parses? | +|-------------|---------| +| Quotes | Yes | +| Examples | Yes | +| Source Code | Yes | +| Center | **No** | +| Comment | **No** | +| Export | **No** | +| Verse | **No** | diff --git a/lib/Data/Org.hs b/lib/Data/Org.hs --- a/lib/Data/Org.hs +++ b/lib/Data/Org.hs @@ -5,7 +5,7 @@ -- | -- Module : Data.Org --- Copyright : (c) Colin Woodbury, 2020 +-- Copyright : (c) Colin Woodbury, 2020 - 2021 -- License : BSD3 -- Maintainer: Colin Woodbury -- @@ -15,11 +15,26 @@ module Data.Org ( -- * Types + -- ** Top-level OrgFile(..) , emptyOrgFile , OrgDoc(..) , emptyDoc + , allDocTags + -- ** Timestamps + , OrgDateTime(..) + , OrgTime(..) + , Repeater(..) + , RepeatMode(..) + , Delay(..) + , DelayMode(..) + , Interval(..) + -- ** Markup , Section(..) + , titled + , allSectionTags + , Todo(..) + , Priority(..) , Block(..) , Words(..) , ListItems(..) @@ -36,10 +51,16 @@ , meta , orgP , section + , properties + , property , paragraph , table , list , line + , timestamp + , date + , timeRange + , repeater -- * Pretty Printing , prettyOrgFile , prettyOrg @@ -50,19 +71,25 @@ import Control.Monad (void, when) import Data.Bool (bool) import Data.Functor (($>)) -import Data.Hashable (Hashable(..)) +import Data.Hashable (Hashable) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NEL import qualified Data.Map.Strict as M +import Data.Maybe (catMaybes, fromMaybe) import Data.Semigroup (sconcat) +import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T +import Data.Time (Day, TimeOfDay(..), fromGregorian, showGregorian) +import Data.Time.Calendar (DayOfWeek(..)) import Data.Void (Void) import GHC.Generics (Generic) import System.FilePath (takeExtension) import Text.Megaparsec hiding (sepBy1, sepEndBy1, some, someTill) import Text.Megaparsec.Char +import Text.Megaparsec.Char.Lexer (decimal) import qualified Text.Megaparsec.Char.Lexer as L +import Text.Printf (printf) -------------------------------------------------------------------------------- -- Types @@ -78,7 +105,7 @@ -- #+AUTHOR: Colin -- @ , orgDoc :: OrgDoc } - deriving stock (Eq, Show, Generic) + deriving stock (Eq, Ord, Show, Generic) emptyOrgFile :: OrgFile emptyOrgFile = OrgFile mempty emptyDoc @@ -96,12 +123,21 @@ data OrgDoc = OrgDoc { docBlocks :: [Block] , docSections :: [Section] } - deriving stock (Eq, Show, Generic) - deriving anyclass (Hashable) + deriving stock (Eq, Ord, Show, Generic) emptyDoc :: OrgDoc emptyDoc = OrgDoc [] [] +-- | All unique section tags in the entire document. +-- +-- Section tags appear on the same row as a header title, but right-aligned. +-- +-- @ +-- * This is a Heading :tag1:tag2: +-- @ +allDocTags :: OrgDoc -> S.Set Text +allDocTags = foldMap allSectionTags . docSections + -- | Some logically distinct block of Org content. data Block = Quote Text @@ -110,9 +146,96 @@ | List ListItems | Table (NonEmpty Row) | Paragraph (NonEmpty Words) - deriving stock (Eq, Show, Generic) - deriving anyclass (Hashable) + deriving stock (Eq, Ord, Show, Generic) +-- | An org-mode timestamp. Must contain at least a year-month-day and the day +-- of the week: +-- +-- @ +-- \<2021-04-27 Tue\> +-- @ +-- +-- but also may contain a time: +-- +-- @ +-- \<2021-04-27 Tue 12:00\> +-- @ +-- +-- or a time range: +-- +-- @ +-- \<2021-04-27 Tue 12:00-13:00\> +-- @ +-- +-- and/or a repeater value: +-- +-- @ +-- \<2021-04-27 Tue +1w\> +-- @ +data OrgDateTime = OrgDateTime + { dateDay :: Day + , dateDayOfWeek :: DayOfWeek + , dateTime :: Maybe OrgTime + , dateRepeat :: Maybe Repeater + , dateDelay :: Maybe Delay } + deriving stock (Eq, Show) + +-- | A lack of a specific `OrgTime` is assumed to mean @00:00@, the earliest +-- possible time for that day. +instance Ord OrgDateTime where + compare (OrgDateTime d0 _ mt0 _ _) (OrgDateTime d1 _ mt1 _ _) = case compare d0 d1 of + LT -> LT + GT -> GT + EQ -> case (mt0, mt1) of + (Nothing, Nothing) -> EQ + (Just _, Nothing) -> GT + (Nothing, Just _) -> LT + (Just t0, Just t1) -> compare t0 t1 + +-- | The time portion of the full timestamp. May be a range, as seen in the +-- following full timestamp: +-- +-- @ +-- \<2021-04-27 Tue 12:00-13:00\> +-- @ +data OrgTime = OrgTime + { timeStart :: TimeOfDay + , timeEnd :: Maybe TimeOfDay } + deriving stock (Eq, Ord, Show) + +-- | An indication of how often a timestamp should be automatically reapplied in +-- the Org Agenda. +data Repeater = Repeater + { repMode :: RepeatMode + , repValue :: Word + , repInterval :: Interval } + deriving stock (Eq, Ord, Show) + +-- | The nature of the repitition. +data RepeatMode + = Single -- ^ Apply the interval value to the original timestamp once: @+@ + | Jump -- ^ Apply the interval value as many times as necessary to arrive on a future date: @++@ + | FromToday -- ^ Apply the interval value from today: @.+@ + deriving stock (Eq, Ord, Show) + +-- | The timestamp repitition unit. +data Interval = Hour | Day | Week | Month | Year + deriving stock (Eq, Ord, Show) + +-- | Delay the appearance of a timestamp in the agenda. +data Delay = Delay + { delayMode :: DelayMode + , delayValue :: Word + , delayInterval :: Interval } + deriving stock (Eq, Ord, Show) + +-- | When a repeater is also present, should the delay be for the first value or +-- all of them? +data DelayMode + = DelayOne -- ^ As in: @--2d@ + | DelayAll -- ^ As in: @-2d@ + deriving stock (Eq, Ord, Show) + -- | A subsection, marked by a heading line and followed recursively by an -- `OrgDoc`. -- @@ -122,12 +245,40 @@ -- This is content in the sub ~OrgDoc~. -- @ data Section = Section - { sectionHeading :: NonEmpty Words - , sectionTags :: [Text] - , sectionDoc :: OrgDoc } - deriving stock (Eq, Show, Generic) - deriving anyclass (Hashable) + { sectionTodo :: Maybe Todo + , sectionPriority :: Maybe Priority + , sectionHeading :: NonEmpty Words + , sectionTags :: [Text] + , sectionClosed :: Maybe OrgDateTime + , sectionDeadline :: Maybe OrgDateTime + , sectionScheduled :: Maybe OrgDateTime + , sectionTimestamp :: Maybe OrgDateTime + -- ^ A timestamp for general events that are neither a DEADLINE nor SCHEDULED. + , sectionProps :: M.Map Text Text + , sectionDoc :: OrgDoc } + deriving stock (Eq, Ord, Show, Generic) +-- | A mostly empty invoking of a `Section`. +titled :: Words -> Section +titled ws = Section Nothing Nothing (ws:|[]) [] Nothing Nothing Nothing Nothing mempty emptyDoc + +-- | All unique tags with a section and its subsections. +allSectionTags :: Section -> S.Set Text +allSectionTags (Section _ _ _ sts _ _ _ _ _ doc) = S.fromList sts <> allDocTags doc + +-- | The completion state of a heading that is considered a "todo" item. +data Todo = TODO | DONE + deriving stock (Eq, Ord, Show, Generic) + +-- | A priority value, usually associated with a @TODO@ marking, as in: +-- +-- @ +-- *** TODO [#A] Cure cancer with Haskell +-- *** TODO [#B] Eat lunch +-- @ +newtype Priority = Priority { priority :: Text } + deriving stock (Eq, Ord, Show, Generic) + -- | An org list constructed of @-@ characters. -- -- @ @@ -140,13 +291,11 @@ -- - Feed the elephant -- @ newtype ListItems = ListItems (NonEmpty Item) - deriving stock (Eq, Show, Generic) - deriving anyclass (Hashable) + deriving stock (Eq, Ord, Show, Generic) -- | A line in a bullet-list. Can contain sublists, as shown in `ListItems`. data Item = Item (NonEmpty Words) (Maybe ListItems) - deriving stock (Eq, Show, Generic) - deriving anyclass (Hashable) + deriving stock (Eq, Ord, Show, Generic) -- | A row in an org table. Can have content or be a horizontal rule. -- @@ -156,13 +305,11 @@ -- | D | E | F | -- @ data Row = Break | Row (NonEmpty Column) - deriving stock (Eq, Show, Generic) - deriving anyclass (Hashable) + deriving stock (Eq, Ord, Show, Generic) -- | A possibly empty column in an org table. data Column = Empty | Column (NonEmpty Words) - deriving stock (Eq, Show, Generic) - deriving anyclass (Hashable) + deriving stock (Eq, Ord, Show, Generic) -- | The fundamental unit of Org text content. `Plain` units are split -- word-by-word. @@ -175,21 +322,19 @@ | Strike Text | Link URL (Maybe Text) | Image URL - | Tags (NonEmpty Text) | Punct Char | Plain Text - deriving stock (Eq, Show, Generic) + deriving stock (Eq, Ord, Show, Generic) deriving anyclass (Hashable) -- | The url portion of a link. newtype URL = URL Text - deriving stock (Eq, Show, Generic) + deriving stock (Eq, Ord, Show, Generic) deriving anyclass (Hashable) -- | The programming language some source code block was written in. newtype Language = Language Text - deriving stock (Eq, Show, Generic) - deriving anyclass (Hashable) + deriving stock (Eq, Ord, Show, Generic) -------------------------------------------------------------------------------- -- Parser @@ -231,24 +376,117 @@ , try table , paragraph ] -- TODO Paragraph needs to fail if it detects a heading. --- | If a line stars with @*@ and a space, it is a `Section` heading. -heading :: Parser (T.Text, NonEmpty Words, [Text]) +-- | If a line starts with @*@ and a space, it is a `Section` heading. +heading :: Parser (T.Text, Maybe Todo, Maybe Priority, NonEmpty Words, [Text]) heading = do stars <- someOf '*' <* char ' ' - ws <- line '\n' - case nelUnsnoc ws of - (Tags ts, Just rest) -> pure (stars, rest, NEL.toList ts) - _ -> pure (stars, ws, []) + (mtd, mpr, ws, mts) <- headerLine + case mts of + Nothing -> pure (stars, mtd, mpr, ws, []) + Just ts -> pure (stars, mtd, mpr, ws, NEL.toList ts) section :: Int -> Parser Section section depth = L.lexeme space $ do - (stars, ws, ts) <- heading + (stars, td, pr, ws, ts) <- heading -- Fail if we've found a parent heading -- when (T.length stars < depth) $ failure Nothing mempty -- Otherwise continue -- + (cl, dl, sc) <- fromMaybe (Nothing, Nothing, Nothing) <$> optional (try $ newline *> hspace *> timestamps) + tm <- optional (try $ newline *> hspace *> stamp) + props <- fromMaybe mempty <$> optional (try $ newline *> hspace *> properties) void space - Section ws ts <$> orgP' (succ depth) + Section td pr ws ts cl dl sc tm props <$> orgP' (succ depth) +timestamps :: Parser (Maybe OrgDateTime, Maybe OrgDateTime, Maybe OrgDateTime) +timestamps = do + mc <- optional closed + void hspace + md <- optional deadline + void hspace + ms <- optional scheduled + case (mc, md, ms) of + (Nothing, Nothing, Nothing) -> failure Nothing mempty + _ -> pure (mc, md, ms) + +-- | An active timestamp. +stamp :: Parser OrgDateTime +stamp = between (char '<') (char '>') timestamp + +closed :: Parser OrgDateTime +closed = string "CLOSED: " *> between (char '[') (char ']') timestamp + +deadline :: Parser OrgDateTime +deadline = string "DEADLINE: " *> stamp + +scheduled :: Parser OrgDateTime +scheduled = string "SCHEDULED: " *> stamp + +timestamp :: Parser OrgDateTime +timestamp = OrgDateTime + <$> date + <*> (hspace1 *> dow) + <*> optional (try $ hspace1 *> timeRange) + <*> optional (try $ hspace1 *> repeater) + <*> optional (hspace1 *> delay) + +date :: Parser Day +date = fromGregorian <$> decimal <*> (char '-' *> decimal) <*> (char '-' *> decimal) + +dow :: Parser DayOfWeek +dow = choice + [ Monday <$ string "Mon" + , Tuesday <$ string "Tue" + , Wednesday <$ string "Wed" + , Thursday <$ string "Thu" + , Friday <$ string "Fri" + , Saturday <$ string "Sat" + , Sunday <$ string "Sun" ] + +timeRange :: Parser OrgTime +timeRange = OrgTime <$> t <*> optional (char '-' *> t) + where + t :: Parser TimeOfDay + t = do + h <- decimal + void $ char ':' + m <- decimal + s <- optional $ do + void $ char ':' + decimal + pure $ TimeOfDay h m (fromMaybe 0 s) + +repeater :: Parser Repeater +repeater = Repeater + <$> choice [ string ".+" $> FromToday, string "++" $> Jump, char '+' $> Single ] + <*> decimal + <*> interval + +delay :: Parser Delay +delay = Delay + <$> choice [ string "--" $> DelayOne, char '-' $> DelayAll ] + <*> decimal + <*> interval + +interval :: Parser Interval +interval = choice [ char 'h' $> Hour, char 'd' $> Day, char 'w' $> Week, char 'm' $> Month, char 'y' $> Year ] + +properties :: Parser (M.Map Text Text) +properties = do + void $ string ":PROPERTIES:" + void newline + void hspace + ps <- (hspace *> property <* newline <* hspace) `manyTill` string ":END:" + pure $ M.fromList ps + +property :: Parser (Text, Text) +property = do + void $ char ':' + key <- someTill' ':' -- TODO Newlines? + void $ char ':' + void hspace + val <- takeWhile1P (Just "Property Value") (/= '\n') + pure (key, val) + quote :: Parser Block quote = L.lexeme space $ do void top <* newline @@ -332,8 +570,18 @@ notFollowedBy heading Paragraph . sconcat <$> sepEndBy1 (line '\n') newline +headerLine :: Parser (Maybe Todo, Maybe Priority, NonEmpty Words, Maybe (NonEmpty Text)) +headerLine = do + td <- optional . try $ (string "TODO" $> TODO) <|> (string "DONE" $> DONE) + void hspace + pr <- optional . try . fmap Priority $ between (char '[') (char ']') (char '#' *> someTill' ']') + void hspace + ws <- (wordChunk '\n' <* hspace) `someTill` lookAhead (try $ void tags <|> void (char '\n') <|> eof) + ts <- optional tags + pure (td, pr, ws, ts) + line :: Char -> Parser (NonEmpty Words) -line end = sepEndBy1 (wordChunk end) (manyOf ' ') +line end = wordChunk end `sepEndBy1` manyOf ' ' -- | RULES -- @@ -354,20 +602,20 @@ , try $ Strike <$> between (char '+') (char '+') (someTill' '+') <* pOrS , try image , try link - , try tags , try $ Punct <$> oneOf punc , Plain <$> takeWhile1P (Just "plain text") (\c -> c /= ' ' && c /= end) ] where + -- | Punctuation, space, or the end of the file. pOrS :: Parser () pOrS = lookAhead $ void (oneOf $ end : ' ' : punc) <|> eof punc :: String punc = ".,!?():;'" -tags :: Parser Words +tags :: Parser (NonEmpty Text) tags = do void $ char ':' - Tags <$> (T.pack . NEL.toList <$> some letterChar) `sepEndBy1` char ':' + (T.pack . NEL.toList <$> some (alphaNumChar <|> char '_' <|> char '@')) `sepEndBy1` char ':' image :: Parser Words image = between (char '[') (char ']') $ @@ -416,17 +664,100 @@ T.intercalate "\n\n" $ map prettyBlock bs <> map (prettySection depth) ss prettySection :: Int -> Section -> Text -prettySection depth (Section ws ts od) = headig <> "\n\n" <> subdoc +prettySection depth (Section td pr ws ts cl dl sc tm ps od) = + T.intercalate "\n" $ catMaybes + [ Just headig + , stamps + , time <$> tm + , props + , Just subdoc ] where + pr' :: Priority -> Text + pr' (Priority t) = "[#" <> t <> "]" + -- TODO There is likely a punctuation bug here. + -- + -- Sun Apr 25 09:59:01 AM PDT 2021: I wish you had elaborated. headig = T.unwords $ T.replicate depth "*" - : NEL.toList (NEL.map prettyWords ws) + : catMaybes [ T.pack . show <$> td, pr' <$> pr ] + <> NEL.toList (NEL.map prettyWords ws) <> bool [":" <> T.intercalate ":" ts <> ":"] [] (null ts) + indent :: Text + indent = T.replicate (depth + 1) " " + + -- | The order of "special" timestamps is CLOSED, DEADLINE, then SCHEDULED. + -- Any permutation of these may appear. + stamps :: Maybe Text + stamps = case catMaybes [fmap cl' cl, fmap dl' dl, fmap sc' sc] of + [] -> Nothing + xs -> Just $ indent <> T.unwords xs + + cl' :: OrgDateTime -> Text + cl' x = "CLOSED: [" <> prettyDateTime x <> "]" + + dl' :: OrgDateTime -> Text + dl' x = "DEADLINE: <" <> prettyDateTime x <> ">" + + sc' :: OrgDateTime -> Text + sc' x = "SCHEDULED: " <> time x + + time :: OrgDateTime -> Text + time x = "<" <> prettyDateTime x <> ">" + + props :: Maybe Text + props + | null ps = Nothing + | otherwise = Just . T.intercalate "\n" $ (indent <> ":PROPERTIES:") : items <> [indent <> ":END:"] + where + items :: [Text] + items = map (\(k, v) -> indent <> ":" <> k <> ": " <> v) $ M.toList ps + subdoc :: Text subdoc = prettyOrg' (succ depth) od +prettyDateTime :: OrgDateTime -> Text +prettyDateTime (OrgDateTime d w t rep del) = + T.unwords $ catMaybes [ Just d', Just w', prettyTime <$> t, prettyRepeat <$> rep, prettyDelay <$> del ] + where + d' :: Text + d' = T.pack $ showGregorian d + + w' :: Text + w' = T.pack . take 3 $ show w + +prettyTime :: OrgTime -> Text +prettyTime (OrgTime s me) = tod s <> maybe "" (\e -> "-" <> tod e) me + where + tod :: TimeOfDay -> Text + tod (TimeOfDay h m _) = T.pack $ printf "%02d:%02d" h m + +prettyRepeat :: Repeater -> Text +prettyRepeat (Repeater m v i) = m' <> T.pack (show v) <> prettyInterval i + where + m' :: Text + m' = case m of + Single -> "+" + Jump -> "++" + FromToday -> ".+" + +prettyDelay :: Delay -> Text +prettyDelay (Delay m v i) = m' <> T.pack (show v) <> prettyInterval i + where + m' :: Text + m' = case m of + DelayOne -> "--" + DelayAll -> "-" + +prettyInterval :: Interval -> Text +prettyInterval i = case i of + Hour -> "h" + Day -> "d" + Week -> "w" + Month -> "m" + Year -> "y" + prettyBlock :: Block -> Text prettyBlock o = case o of Code l t -> "#+begin_src" <> maybe "" (\(Language l') -> " " <> l' <> "\n") l @@ -479,9 +810,5 @@ Link (URL url) Nothing -> "[[" <> url <> "]]" Link (URL url) (Just t) -> "[[" <> url <> "][" <> t <> "]]" Image (URL url) -> "[[" <> url <> "]]" - Tags ts -> ":" <> T.intercalate ":" (NEL.toList ts) <> ":" Punct c -> T.singleton c Plain t -> t - -nelUnsnoc :: NonEmpty a -> (a, Maybe (NonEmpty a)) -nelUnsnoc ne = (NEL.last ne, NEL.nonEmpty $ NEL.init ne) diff --git a/org-mode.cabal b/org-mode.cabal --- a/org-mode.cabal +++ b/org-mode.cabal @@ -1,13 +1,13 @@ cabal-version: 2.2 name: org-mode -version: 1.1.1 +version: 2.0.0 synopsis: Parser for Emacs org-mode files. description: Parser for Emacs org-mode files. category: Data homepage: https://github.com/fosskers/org-mode author: Colin Woodbury maintainer: colin@fosskers.ca -copyright: 2020 Colin Woodbury +copyright: 2020 - 2021 Colin Woodbury license: BSD-3-Clause license-file: LICENSE build-type: Simple @@ -22,8 +22,7 @@ default-extensions: OverloadedStrings ghc-options: -Wall -Wpartial-fields -Wincomplete-record-updates - -Wincomplete-uni-patterns -Widentities - -funclutter-valid-hole-fits + -Wincomplete-uni-patterns -Widentities -funclutter-valid-hole-fits build-depends: , base >=4.12 && <5 @@ -39,6 +38,7 @@ , filepath , hashable >=1.2 && <1.4 , parser-combinators >=1.1 && <1.3 + , time >=1.9 test-suite org-mode-test import: commons @@ -50,3 +50,4 @@ , org-mode , tasty ^>=1.2 , tasty-hunit ^>=0.10 + , time >=1.9 diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -7,6 +7,8 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T +import Data.Time.Calendar (DayOfWeek(..), fromGregorian) +import Data.Time.LocalTime (TimeOfDay(..)) import Data.Void (Void) import Test.Tasty import Test.Tasty.HUnit @@ -27,29 +29,137 @@ suite :: T.Text -> T.Text -> TestTree suite simple full = testGroup "Unit Tests" [ testGroup "Basic Markup" - [ testCase "Header" $ parseMaybe (section 1) "* A" - @?= Just (Section [Plain "A"] [] emptyDoc) + [ testCase "Header" $ parseMaybe (section 1) "* A" @?= Just (titled (Plain "A")) , testCase "Header - Subsection" $ parseMaybe (section 1) "* A\n** B" - @?= Just (Section [Plain "A"] [] (OrgDoc [] [Section [Plain "B"] [] emptyDoc])) + @?= Just ((titled (Plain "A")) { sectionDoc = OrgDoc [] [titled (Plain "B")] }) + , testCase "Header - Back again" $ testPretty orgP "Header" "* A\n** B\n* C" - $ OrgDoc [] [ Section [Plain "A"] [] (OrgDoc [] [Section [Plain "B"] [] emptyDoc]) - , Section [Plain "C"] [] emptyDoc ] + $ OrgDoc [] [ (titled (Plain "A")) { sectionDoc = OrgDoc [] [titled (Plain "B")] }, titled (Plain "C") ] + , testCase "Header - Contents" $ testPretty orgP "Header" "* A\nD\n\n** B\n* C" -- TODO Requires an extra newline! $ OrgDoc [] - [ Section [Plain "A"] [] (OrgDoc [Paragraph [Plain "D"]] [Section [Plain "B"] [] emptyDoc]) - , Section [Plain "C"] [] emptyDoc ] - , testCase "Header - Tags" + [ (titled (Plain "A")) { sectionDoc = OrgDoc [Paragraph [Plain "D"]] [ titled (Plain "B") ] } + , titled (Plain "C") ] + + , testCase "Header - TODO" + $ testPretty orgP "Header" "* TODO A" + $ OrgDoc [] + [ (titled (Plain "A")) { sectionTodo = Just TODO }] + + , testCase "Header - Priority" + $ testPretty orgP "Header" "* [#A] A" + $ OrgDoc [] + [ (titled (Plain "A")) { sectionPriority = Just $ Priority "A" }] + + , testCase "Header - TODO + Priority" + $ testPretty orgP "Header" "* TODO [#A] A" + $ OrgDoc [] + [ (titled (Plain "A")) { sectionTodo = Just TODO, sectionPriority = Just $ Priority "A" }] + + , testCase "Header - One line, single tag" + $ testPretty orgP "Header" "* A :this:" + $ OrgDoc [] [ (titled (Plain "A")) { sectionTags = ["this"] } ] + + , testCase "Header - One line, multiple tags" $ testPretty orgP "Header" "* A :this:that:" - $ OrgDoc [] [Section [Plain "A"] ["this", "that"] emptyDoc] + $ OrgDoc [] [ (titled (Plain "A")) { sectionTags = ["this", "that"] } ] + , testCase "Header - More Tags" $ testPretty orgP "Header" "* A :this:that:\n** B :other:\n* C" $ OrgDoc [] - [ Section [Plain "A"] ["this", "that"] (OrgDoc [] [Section [Plain "B"] ["other"] emptyDoc]) - , Section [Plain "C"] [] emptyDoc - ] + [ (titled (Plain "A")) + { sectionTags = ["this", "that"] + , sectionDoc = OrgDoc [] [ (titled (Plain "B")) { sectionTags = ["other"] } ] } + , titled (Plain "C") ] + , testCase "Header - Non-tag Smiley" + $ testPretty orgP "Header" "* A :)" + $ OrgDoc [] [ Section Nothing Nothing [Plain "A", Punct ':', Punct ')'] [] Nothing Nothing Nothing Nothing mempty emptyDoc ] + + , testCase "Header - Vanilla Timestamp" + $ testPretty orgP "Header" "* A\n <2021-04-19 Mon>" + $ let tm = OrgDateTime { dateDay = fromGregorian 2021 4 19 + , dateDayOfWeek = Monday + , dateTime = Nothing + , dateRepeat = Nothing + , dateDelay = Nothing } + in OrgDoc [] [ (titled (Plain "A")) { sectionTimestamp = Just tm } ] + + , testCase "Header - CLOSED" + $ testPretty orgP "Header" "* A\n CLOSED: [2021-04-19 Mon 15:43]" + $ let cl = OrgDateTime { dateDay = fromGregorian 2021 4 19 + , dateDayOfWeek = Monday + , dateTime = Just $ OrgTime (TimeOfDay 15 43 0) Nothing + , dateRepeat = Nothing + , dateDelay = Nothing } + in OrgDoc [] [ (titled (Plain "A")) { sectionClosed = Just cl } ] + + , testCase "Header - DEADLINE" + $ testPretty orgP "Header" "* A\n DEADLINE: <2021-04-19 Mon>" + $ let dl = OrgDateTime { dateDay = fromGregorian 2021 4 19 + , dateDayOfWeek = Monday + , dateTime = Nothing + , dateRepeat = Nothing + , dateDelay = Nothing } + in OrgDoc [] [ (titled (Plain "A")) { sectionDeadline = Just dl } ] + + , testCase "Header - SCHEDULED" + $ testPretty orgP "Header" "* A\n SCHEDULED: <2021-04-19 Mon>" + $ let sc = OrgDateTime { dateDay = fromGregorian 2021 4 19 + , dateDayOfWeek = Monday + , dateTime = Nothing + , dateRepeat = Nothing + , dateDelay = Nothing } + in OrgDoc [] [ (titled (Plain "A")) { sectionScheduled = Just sc } ] + + , testCase "Header - CLOSED/DEADLINE" + $ testPretty orgP "Header" "* A\n CLOSED: [2021-04-19 Mon 15:43] DEADLINE: <2021-04-19 Mon>" + $ let dl = OrgDateTime { dateDay = fromGregorian 2021 4 19 + , dateDayOfWeek = Monday + , dateTime = Nothing + , dateRepeat = Nothing + , dateDelay = Nothing } + cl = OrgDateTime { dateDay = fromGregorian 2021 4 19 + , dateDayOfWeek = Monday + , dateTime = Just $ OrgTime (TimeOfDay 15 43 0) Nothing + , dateRepeat = Nothing + , dateDelay = Nothing } + in OrgDoc [] [ (titled (Plain "A")) { sectionClosed = Just cl, sectionDeadline = Just dl } ] + + , testCase "Header - CLOSED/DEADLINE - More" + $ testPretty orgP "Header" "* A\n CLOSED: [2021-04-19 Mon 15:43] DEADLINE: <2021-04-19 Mon>\nD" + $ let dl = OrgDateTime { dateDay = fromGregorian 2021 4 19 + , dateDayOfWeek = Monday + , dateTime = Nothing + , dateRepeat = Nothing + , dateDelay = Nothing } + cl = OrgDateTime { dateDay = fromGregorian 2021 4 19 + , dateDayOfWeek = Monday + , dateTime = Just $ OrgTime (TimeOfDay 15 43 0) Nothing + , dateRepeat = Nothing + , dateDelay = Nothing } + in OrgDoc [] [ Section Nothing Nothing [Plain "A"] [] (Just cl) (Just dl) Nothing Nothing mempty (OrgDoc [ Paragraph [Plain "D"]] []) ] + + , testCase "Header - Empty Properties Drawer" + $ testPretty orgP "Header" "* A\n :PROPERTIES:\n :END:" + $ OrgDoc [] [ titled (Plain "A") ] + + , testCase "Header - One Property" + $ testPretty orgP "Header" "* A\n :PROPERTIES:\n :Cat: Jack\n :END:\nHi" + $ OrgDoc [] [ (titled (Plain "A")) + { sectionProps = [("Cat", "Jack")] + , sectionDoc = OrgDoc [Paragraph [Plain "Hi"]] [] }] + + , testCase "Header - Two Properties" + $ testPretty orgP "Header" "* A\n :PROPERTIES:\n :Cat: Jack\n :Age: 7\n :END:" + $ OrgDoc [] [ (titled (Plain "A")) { sectionProps = [("Cat", "Jack"), ("Age", "7")] } ] + + , testCase "Properties" + $ testPretty properties "Properties" ":PROPERTIES:\n :Cat: Jack\n :END:" [("Cat", "Jack")] + , testCase "Property" $ testPretty property "Property" ":Cat: Jack" ("Cat", "Jack") + , testCase "Bold" $ parseMaybe orgP "*Bold*" @?= Just (OrgDoc [Paragraph [Bold "Bold"]] []) , testCase "Italics" $ parseMaybe orgP "/Italic/" @@ -100,6 +210,62 @@ , testCase "Line - Dummy markup symbol" $ testPretty (line '\n') "Line" "A ~ B" [Plain "A", Plain "~", Plain "B"] ] + , testGroup "Timestamps" + [ testCase "Repeater" $ testPretty repeater "Repeater" "+2w" (Repeater Single 2 Week) + , testCase "Time - Morning" $ testPretty timeRange "Time" "09:30" (OrgTime (TimeOfDay 9 30 0) Nothing) + , testCase "Time - Afternoon" $ testPretty timeRange "Time" "14:30" (OrgTime (TimeOfDay 14 30 0) Nothing) + , testCase "Time - Range" $ testPretty timeRange "Time" "09:30-14:30" (OrgTime (TimeOfDay 9 30 0) (Just (TimeOfDay 14 30 0))) + , testCase "Date" $ testPretty date "Date" "2021-04-27" $ fromGregorian 2021 4 27 + , testCase "Timestamp - No time" $ testPretty timestamp "Stamp" "2021-04-27 Tue" + $ OrgDateTime + { dateDay = fromGregorian 2021 4 27 + , dateDayOfWeek = Tuesday + , dateTime = Nothing + , dateRepeat = Nothing + , dateDelay = Nothing } + , testCase "Timestamp - Time" $ testPretty timestamp "Stamp" "2021-04-27 Tue 09:30" + $ OrgDateTime + { dateDay = fromGregorian 2021 4 27 + , dateDayOfWeek = Tuesday + , dateTime = Just $ OrgTime (TimeOfDay 9 30 0) Nothing + , dateRepeat = Nothing + , dateDelay = Nothing } + , testCase "Timestamp - Repeat Single" $ testPretty timestamp "Stamp" "2021-04-27 Tue +2w" + $ OrgDateTime + { dateDay = fromGregorian 2021 4 27 + , dateDayOfWeek = Tuesday + , dateTime = Nothing + , dateRepeat = Just $ Repeater Single 2 Week + , dateDelay = Nothing } + , testCase "Timestamp - Repeat Jump" $ testPretty timestamp "Stamp" "2021-04-27 Tue ++2w" + $ OrgDateTime + { dateDay = fromGregorian 2021 4 27 + , dateDayOfWeek = Tuesday + , dateTime = Nothing + , dateRepeat = Just $ Repeater Jump 2 Week + , dateDelay = Nothing } + , testCase "Timestamp - Time and Repeat" $ testPretty timestamp "Stamp" "2021-04-27 Tue 09:30 +2w" + $ OrgDateTime + { dateDay = fromGregorian 2021 4 27 + , dateDayOfWeek = Tuesday + , dateTime = Just $ OrgTime (TimeOfDay 9 30 0) Nothing + , dateRepeat = Just $ Repeater Single 2 Week + , dateDelay = Nothing } + , testCase "Timestamp - Delay" $ testPretty timestamp "Stamp" "2021-04-27 Tue -3d" + $ OrgDateTime + { dateDay = fromGregorian 2021 4 27 + , dateDayOfWeek = Tuesday + , dateTime = Nothing + , dateRepeat = Nothing + , dateDelay = Just $ Delay DelayAll 3 Day } + , testCase "Timestamp - Repeat and Delay" $ testPretty timestamp "Stamp" "2021-04-27 Tue +2w -3d" + $ OrgDateTime + { dateDay = fromGregorian 2021 4 27 + , dateDayOfWeek = Tuesday + , dateTime = Nothing + , dateRepeat = Just $ Repeater Single 2 Week + , dateDelay = Just $ Delay DelayAll 3 Day } + ] , testGroup "Composite Structures" [ testCase "Example" $ parseMaybe orgP "#+begin_example\nHi!\n\nHo\n#+end_example" @?= Just (OrgDoc [Example "Hi!\n\nHo"] []) @@ -192,6 +358,8 @@ Right r -> case parse orgFile "test.org - reparse" (prettyOrgFile r) of Left eb' -> assertFailure $ errorBundlePretty eb' Right r' -> r' @?= r + , testCase "Full: Tag Extraction" + $ (allDocTags . orgDoc <$> parse orgFile "test.org" full) @?= Right ["tag1", "tag2", "tag3"] ] , testGroup "Megaparsec Sanity" [ testCase "sepEndBy1" $ testPretty sepTest "sepBy1" "A.A.A.B" ['A', 'A', 'A'] diff --git a/test/simple.org b/test/simple.org --- a/test/simple.org +++ b/test/simple.org @@ -11,5 +11,8 @@ Text! * Heading 3 + :PROPERTIES: + :Yes: Fun + :END: More text! diff --git a/test/test.org b/test/test.org --- a/test/test.org +++ b/test/test.org @@ -5,11 +5,11 @@ Some text before the initial heading. -* A Heading +* A Heading :tag1: -** A subheading +** A subheading :tag2: -*** We have to go deeper +*** We have to go deeper :tag3: *This is some bold text* within a normal paragraph. However I should tell you that the paragraph doesn't end there. It has multiple lines! Oh, but having only @@ -23,7 +23,7 @@ main = putStrLn "org-mode tests" #+end_src -** More +** More :tag2: And a quote. @@ -32,6 +32,23 @@ - Albert Einstein #+end_quote + +** Not a tag! :) + +** DONE Gotta do it + CLOSED: [2021-04-28 Wed 15:10] DEADLINE: <2021-04-29 Thu> SCHEDULED: <2021-04-28 Wed> + <2021-04-25 Sun> + +Stuff. + +** TODO [#A] Laundry + SCHEDULED: <2021-04-30 Fri 13:00 .+1w -1d> + +** Props + <2021-04-28 Wed> + :PROPERTIES: + :Yes: Fun + :END: * Another Heading!