org-mode 1.1.1 → 2.0.0

raw patch · 8 files changed

+644/−69 lines, 8 filesdep +timePVP ok

version bump matches the API change (PVP)

Dependencies added: time

API changes (from Hackage documentation)

Files

• CHANGELOG.md +21/−0
• LICENSE +1/−1
• README.md +43/−5
• lib/Data/Org.hs +370/−43
• org-mode.cabal +5/−4
• test/Test.hs +180/−12
• test/simple.org +3/−0
• test/test.org +21/−4

@@ -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

@@ -1,4 +1,4 @@-Copyright Colin Woodbury (c) 2020+Copyright Colin Woodbury (c) 2020 - 2021  All rights reserved. 

@@ -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**  |

@@ -5,7 +5,7 @@  -- | -- Module    : Data.Org--- Copyright : (c) Colin Woodbury, 2020+-- Copyright : (c) Colin Woodbury, 2020 - 2021 -- License   : BSD3 -- Maintainer: Colin Woodbury <colin@fosskers.ca> --@@ -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)

@@ -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

@@ -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']

@@ -11,5 +11,8 @@ Text!  * Heading 3+  :PROPERTIES:+  :Yes: Fun+  :END:  More text!

@@ -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!