{-# LANGUAGE CPP                 #-}
{-# LANGUAGE InstanceSigs        #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData          #-}
{-# LANGUAGE ViewPatterns        #-}
--------------------------------------------------------------------
-- |
-- Module      :  XMonad.Prompt.OrgMode
-- Description :  A prompt for interacting with org-mode.
-- Copyright   :  (c) 2021  Tony Zorman
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  Tony Zorman <soliditsallgood@mailbox.org>
-- Stability   :  experimental
-- Portability :  unknown
--
-- A prompt for interacting with <https:\/\/orgmode.org\/ org-mode>.
-- This can be seen as an org-specific version of
-- "XMonad.Prompt.AppendFile", allowing for more interesting
-- interactions with that particular file type.
--
-- It can be used to quickly save TODOs, NOTEs, and the like with the
-- additional capability to schedule/deadline a task, add a priority,
-- refile to some existing heading, and use the system's clipboard
-- (really: the primary selection) as the contents of the note.
--
-- A blog post highlighting some features of this module can be found
-- <https://tony-zorman.com/posts/orgmode-prompt/2022-08-27-xmonad-and-org-mode.html here>.
--
--------------------------------------------------------------------
module XMonad.Prompt.OrgMode (
    -- * Usage
    -- $usage

    -- * Prompts
    orgPrompt,              -- :: XPConfig -> String -> FilePath -> X ()
    orgPromptRefile,        -- :: XPConfig -> [String] -> String -> FilePath -> X ()
    orgPromptRefileTo,      -- :: XPConfig -> String -> String -> FilePath -> X ()
    orgPromptPrimary,       -- :: XPConfig -> String -> FilePath -> X ()

    -- * Types
    ClipboardSupport (..),
    OrgMode,                -- abstract

#ifdef TESTING
    pInput,
    Note (..),
    Priority (..),
    Date (..),
    Time (..),
    TimeOfDay (..),
    OrgTime (..),
    DayOfWeek (..),
#endif

) where

import XMonad.Prelude

import XMonad (X, io, whenJust)
import XMonad.Prompt (XPConfig, XPrompt (showXPrompt), mkXPromptWithReturn, mkComplFunFromList, ComplFunction)
import XMonad.Util.Parser
import XMonad.Util.XSelection (getSelection)
import XMonad.Util.Run

import Control.DeepSeq (deepseq)
import qualified Data.List.NonEmpty as NE (head)
import Data.Time (Day (ModifiedJulianDay), NominalDiffTime, UTCTime (utctDay), addUTCTime, fromGregorian, getCurrentTime, nominalDay, toGregorian)
#if MIN_VERSION_time(1, 9, 0)
import Data.Time.Format.ISO8601 (iso8601Show)
#else
import Data.Time.Format (defaultTimeLocale, formatTime, iso8601DateFormat)
#endif
import GHC.Natural (Natural)
import System.IO (IOMode (AppendMode, ReadMode), hClose, hGetContents, openFile, withFile)

{- $usage

You can use this module by importing it, along with "XMonad.Prompt", in
your @xmonad.hs@

> import XMonad.Prompt
> import XMonad.Prompt.OrgMode (orgPrompt)

and adding an appropriate keybinding.  For example, using syntax from
"XMonad.Util.EZConfig":

> , ("M-C-o", orgPrompt def "TODO" "/home/me/org/todos.org")

This would create notes of the form @* TODO /my-message/@ in the
specified file.

You can also enter a relative path; in that case the file path will be
prepended with @$HOME@ or an equivalent directory.  I.e. instead of the
above you can write

> , ("M-C-o", orgPrompt def "TODO" "org/todos.org")
>                -- also possible: "~/org/todos.org"

There is also some scheduling and deadline functionality present.  This
may be initiated by entering @+s@ or @+d@—separated by at least one
whitespace character on either side—into the prompt, respectively.
Then, one may enter a date and (optionally) a time of day.  Any of the
following are valid dates, where brackets indicate optionality:

  - tod[ay]
  - tom[orrow]
  - /any weekday/
  - /any date of the form DD [MM] [YYYY]/

In the last case, the missing month and year will be filled out with the
current month and year.

For weekdays, we also disambiguate as early as possible; a simple @w@
will suffice to mean Wednesday, but @s@ will not be enough to say
Sunday.  You can, however, also write the full word without any
troubles.  Weekdays always schedule into the future; e.g., if today is
Monday and you schedule something for Monday, you will actually schedule
it for the /next/ Monday (the one in seven days).

The time is specified in the @HH:MM@ or @HHMM@ format.  The minutes may
be omitted, in which case we assume a full hour is specified.  It is also
possible to enter a time span using the syntax @HH:MM-HH:MM@ or @HH:MM+HH@.
In the former case, minutes may be omitted.

A few examples are probably in order.  Suppose we have bound the key
above, pressed it, and are now confronted with a prompt:

  - @hello +s today@ would create a TODO note with the header @hello@
    and would schedule that for today's date.

  - @hello +s today 12@ schedules the note for today at 12:00.

  - @hello +s today 12:30@ schedules it for today at 12:30.

  - @hello +d today 12:30@ works just like above, but creates a
    deadline.

  - @hello +d today 12:30-14:30@ works like the above, but gives the
    event a duration of two hours.  An alternative way to specify
    this would be @hello +d today 12:30+2@.

  - @hello +s thu@ would schedule the note for next thursday.

  - @hello +s 11@ would schedule it for the 11th of this month and this
    year.

  - @hello +s 11 jan 2013@ would schedule the note for the 11th of
    January 2013.

Note that, due to ambiguity concerns, years below @25@ result in
undefined parsing behaviour.  Otherwise, what should @message +s 11 jan
13@ resolve to—the 11th of january at 13:00 or the 11th of january in
the year 13?

There is basic support for alphabetic org-mode
<https:\/\/orgmode.org\/manual\/Priorities.html priorities>.
Simply append either @#A@, @#B@, or @#C@ (capitalisation is optional) to
the end of the note.  For example, one could write @"hello +s 11 jan
2013 #A"@ or @"hello #C"@.  Note that there has to be at least one
whitespace character between the end of the note and the chosen
priority.

There's also the possibility to take what's currently in the primary
selection and paste that as the content of the created note.  This is
especially useful when you want to quickly save a URL for later and
return to whatever you were doing before.  See the 'orgPromptPrimary'
prompt for that.

Finally, 'orgPromptRefile' and 'orgPromptRefileTo' provide support to
automatically
<https://orgmode.org/manual/Refile-and-Copy.html refile>
the generated item under a heading of choice.  For example, binding

> orgPromptRefile def "TODO" "todos.org"

to a key will first pop up an ordinary prompt that works exactly like
'orgPrompt', and then query the user for an already existing heading
(with completions) as provided by the @~/todos.org@ file.  If that
prompt is cancelled, the heading will appear in the org file as normal
(i.e., at the end of the file); otherwise, it gets refiled under the
selected heading.

-}

{- TODO

  - XMonad.Util.XSelection.getSelection is really, really horrible.  The
    plan would be to rewrite this in a way so it uses xmonad's
    connection to the X server.

  - Add option to explicitly use the system clipboard instead of the
    primary selection.

-}

------------------------------------------------------------------------
-- Prompt

data OrgMode = OrgMode
  { OrgMode -> ClipboardSupport
clpSupport :: ClipboardSupport
  , OrgMode -> [Char]
todoHeader :: String    -- ^ Will display like @* todoHeader @
  , OrgMode -> [Char]
orgFile    :: FilePath
  }

mkOrgCfg :: ClipboardSupport -> String -> FilePath -> X OrgMode
mkOrgCfg :: ClipboardSupport -> [Char] -> [Char] -> X OrgMode
mkOrgCfg ClipboardSupport
clp [Char]
header [Char]
fp = ClipboardSupport -> [Char] -> [Char] -> OrgMode
OrgMode ClipboardSupport
clp [Char]
header forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadIO m => [Char] -> m [Char]
mkAbsolutePath [Char]
fp

-- | Whether we should use a clipboard and which one to use.
data ClipboardSupport
  = PrimarySelection
  | NoClpSupport

-- | How one should display the clipboard string.
data Clp
  = Header String  -- ^ In the header as a link: @* [[clp][message]]@
  | Body   String  -- ^ In the body as additional text: @* message \n clp@

instance XPrompt OrgMode where
  showXPrompt :: OrgMode -> String
  showXPrompt :: OrgMode -> [Char]
showXPrompt OrgMode{ [Char]
todoHeader :: [Char]
todoHeader :: OrgMode -> [Char]
todoHeader, [Char]
orgFile :: [Char]
orgFile :: OrgMode -> [Char]
orgFile, ClipboardSupport
clpSupport :: ClipboardSupport
clpSupport :: OrgMode -> ClipboardSupport
clpSupport } =
    forall a. Monoid a => [a] -> a
mconcat [[Char]
"Add ", [Char]
todoHeader, [Char]
clp, [Char]
" to ", [Char]
orgFile, [Char]
": "]
   where
    [Char]
clp :: String = case ClipboardSupport
clpSupport of
      ClipboardSupport
NoClpSupport     -> [Char]
""
      ClipboardSupport
PrimarySelection -> [Char]
" + PS"

-- | Prompt for interacting with @org-mode@.
orgPrompt
  :: XPConfig  -- ^ Prompt configuration
  -> String    -- ^ What kind of note to create; will be displayed after
               --   a single @*@
  -> FilePath  -- ^ Path to @.org@ file, e.g. @home\/me\/todos.org@
  -> X ()
orgPrompt :: XPConfig -> [Char] -> [Char] -> X ()
orgPrompt XPConfig
xpc = (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPConfig -> OrgMode -> X Bool
mkOrgPrompt XPConfig
xpc forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b c d. (a -> b) -> (c -> d -> a) -> c -> d -> b
.: ClipboardSupport -> [Char] -> [Char] -> X OrgMode
mkOrgCfg ClipboardSupport
NoClpSupport

-- | Like 'orgPrompt', but additionally make use of the primary
-- selection.  If it is a URL, then use an org-style link
-- @[[primary-selection][entered message]]@ as the heading.  Otherwise,
-- use the primary selection as the content of the note.
--
-- The prompt will display a little @+ PS@ in the window
-- after the type of note.
orgPromptPrimary :: XPConfig -> String -> FilePath -> X ()
orgPromptPrimary :: XPConfig -> [Char] -> [Char] -> X ()
orgPromptPrimary XPConfig
xpc = (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPConfig -> OrgMode -> X Bool
mkOrgPrompt XPConfig
xpc forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b c d. (a -> b) -> (c -> d -> a) -> c -> d -> b
.: ClipboardSupport -> [Char] -> [Char] -> X OrgMode
mkOrgCfg ClipboardSupport
PrimarySelection

-- | Internal type in order to generate a nice prompt in
-- 'orgPromptRefile' and 'orgPromptRefileTo'.
data RefilePrompt = Refile
instance XPrompt RefilePrompt where
  showXPrompt :: RefilePrompt -> String
  showXPrompt :: RefilePrompt -> [Char]
showXPrompt RefilePrompt
Refile = [Char]
"Refile note to: "

-- | Like 'orgPrompt' (which see for the other arguments), but offer to
-- refile the entered note afterwards.
--
-- Note that refiling is done by shelling out to Emacs, hence an @emacs@
-- binary must be in @$PATH@.  One may customise this by following the
-- instructions in "XMonad.Util.Run#g:EDSL"; more specifically, by
-- changing the 'XMonad.Util.Run.emacs' field of
-- 'XMonad.Util.Run.ProcessConfig'.
orgPromptRefile :: XPConfig -> String -> FilePath -> X ()
orgPromptRefile :: XPConfig -> [Char] -> [Char] -> X ()
orgPromptRefile XPConfig
xpc [Char]
str [Char]
fp = do
  OrgMode
orgCfg <- ClipboardSupport -> [Char] -> [Char] -> X OrgMode
mkOrgCfg ClipboardSupport
NoClpSupport [Char]
str [Char]
fp

  -- NOTE: Ideally we would just use System.IO.readFile' here
  -- (especially because it also reads everything strictly), but this is
  -- only available starting in base 4.15.x.
  [Char]
fileContents <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ do
    Handle
handle   <- [Char] -> IOMode -> IO Handle
openFile (OrgMode -> [Char]
orgFile OrgMode
orgCfg) IOMode
ReadMode
    [Char]
contents <- Handle -> IO [Char]
hGetContents Handle
handle
    [Char]
contents forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ([Char]
contents forall a b. NFData a => a -> b -> b
`deepseq` Handle -> IO ()
hClose Handle
handle)

  -- Save the entry as soon as possible.
  Bool
notCancelled <- XPConfig -> OrgMode -> X Bool
mkOrgPrompt XPConfig
xpc OrgMode
orgCfg
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
notCancelled forall a b. (a -> b) -> a -> b
$
    -- If the user didn't cancel, try to parse the org file and offer to
    -- refile the entry if possible.
    forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (forall a. Parser a -> [Char] -> Maybe a
runParser Parser [Heading]
pOrgFile [Char]
fileContents) forall a b. (a -> b) -> a -> b
$ \[Heading]
headings ->
      forall p a.
XPrompt p =>
p -> XPConfig -> ComplFunction -> ([Char] -> X a) -> X (Maybe a)
mkXPromptWithReturn RefilePrompt
Refile XPConfig
xpc ([Heading] -> ComplFunction
completeHeadings [Heading]
headings) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe [Char]
Nothing     -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just [Char]
parent -> [Char] -> [Char] -> X ()
refile [Char]
parent (OrgMode -> [Char]
orgFile OrgMode
orgCfg)
 where
  completeHeadings :: [Heading] -> ComplFunction
  completeHeadings :: [Heading] -> ComplFunction
completeHeadings = XPConfig -> [[Char]] -> ComplFunction
mkComplFunFromList XPConfig
xpc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Heading -> [Char]
headingText

-- | Like 'orgPromptRefile', but with a fixed heading for refiling; no
-- prompt will appear to query for a target.
--
-- Heading names may omit tags, but generally need to be prefixed by the
-- correct todo keywords; e.g.,
--
-- > orgPromptRefileTo def "PROJECT Work" "TODO" "~/todos.org"
--
-- Will refile the created note @"TODO <text>"@ to the @"PROJECT Work"@
-- heading, even with the actual name is @"PROJECT Work
-- :work:other_tags:"@.  Just entering @"Work"@ will not work, as Emacs
-- doesn't recognise @"PROJECT"@ as an Org keyword by default (i.e. when
-- started in batch-mode).
orgPromptRefileTo
  :: XPConfig
  -> String     -- ^ Heading to refile the entry under.
  -> String
  -> FilePath
  -> X ()
orgPromptRefileTo :: XPConfig -> [Char] -> [Char] -> [Char] -> X ()
orgPromptRefileTo XPConfig
xpc [Char]
refileHeading [Char]
str [Char]
fp = do
  OrgMode
orgCfg       <- ClipboardSupport -> [Char] -> [Char] -> X OrgMode
mkOrgCfg ClipboardSupport
NoClpSupport [Char]
str [Char]
fp
  Bool
notCancelled <- XPConfig -> OrgMode -> X Bool
mkOrgPrompt XPConfig
xpc OrgMode
orgCfg
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
notCancelled forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> X ()
refile [Char]
refileHeading (OrgMode -> [Char]
orgFile OrgMode
orgCfg)

-- | Create the actual prompt.  Returns 'False' when the input was
-- cancelled by the user (by, for example, pressing @Esc@ or @C-g@) and
-- 'True' otherwise.
mkOrgPrompt :: XPConfig -> OrgMode -> X Bool
mkOrgPrompt :: XPConfig -> OrgMode -> X Bool
mkOrgPrompt XPConfig
xpc oc :: OrgMode
oc@OrgMode{ [Char]
todoHeader :: [Char]
todoHeader :: OrgMode -> [Char]
todoHeader, [Char]
orgFile :: [Char]
orgFile :: OrgMode -> [Char]
orgFile, ClipboardSupport
clpSupport :: ClipboardSupport
clpSupport :: OrgMode -> ClipboardSupport
clpSupport } =
  forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall p a.
XPrompt p =>
p -> XPConfig -> ComplFunction -> ([Char] -> X a) -> X (Maybe a)
mkXPromptWithReturn OrgMode
oc XPConfig
xpc (forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure [])) [Char] -> X ()
appendNote
 where
  -- | Parse the user input, create an @org-mode@ note out of that and
  -- try to append it to the given file.
  appendNote :: String -> X ()
  appendNote :: [Char] -> X ()
appendNote [Char]
input = forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ do
    Clp
clpStr <- case ClipboardSupport
clpSupport of
      ClipboardSupport
NoClpSupport     -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Char] -> Clp
Body [Char]
""
      ClipboardSupport
PrimarySelection -> do
        [Char]
sel <- forall (m :: * -> *). MonadIO m => m [Char]
getSelection
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if   forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
sel) [[Char]
"http://", [Char]
"https://"]
               then [Char] -> Clp
Header [Char]
sel
               else [Char] -> Clp
Body   forall a b. (a -> b) -> a -> b
$ [Char]
"\n " forall a. Semigroup a => a -> a -> a
<> [Char]
sel

    forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
withFile [Char]
orgFile IOMode
AppendMode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip Handle -> [Char] -> IO ()
hPutStrLn
      forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"") (Clp -> [Char] -> Note -> IO [Char]
ppNote Clp
clpStr [Char]
todoHeader) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Maybe Note
pInput
        forall a b. (a -> b) -> a -> b
$ [Char]
input

------------------------------------------------------------------------
-- Refiling

-- | Let Emacs do the refiling, as this seems—and I know how this
-- sounds—more robust than trying to do it ad-hoc in this module.
refile :: String -> FilePath -> X ()
refile :: [Char] -> [Char] -> X ()
refile ([Char] -> [Char]
asString -> [Char]
parent) ([Char] -> [Char]
asString -> [Char]
fp) =
  X ([Char] -> [Char]) -> X ()
proc forall a b. (a -> b) -> a -> b
$ X ([Char] -> [Char])
inEmacs
     X ([Char] -> [Char])
-> X ([Char] -> [Char]) -> X ([Char] -> [Char])
>-> X ([Char] -> [Char])
asBatch
     X ([Char] -> [Char])
-> X ([Char] -> [Char]) -> X ([Char] -> [Char])
>-> [Char] -> X ([Char] -> [Char])
eval ([[Char]] -> [Char]
progn [ [Char]
"find-file" forall a. Semigroup a => a -> a -> a
<> [Char]
fp
                     , [Char]
"end-of-buffer"
                     , [Char]
"org-refile nil nil"
                         forall a. Semigroup a => a -> a -> a
<> [[Char]] -> [Char]
list [ [Char]
parent
                                 , [Char]
fp
                                 , [Char]
"nil"
                                 , [[Char]] -> [Char]
saveExcursion [[Char]
"org-find-exact-headline-in-buffer"
                                                    forall a. Semigroup a => a -> a -> a
<> [Char]
parent]
                                 ]
                     , [Char]
"save-buffer"
                     ])

------------------------------------------------------------------------
-- Time

-- | A 'Time' is a 'Date' with the possibility of having a specified
-- @HH:MM@ time.
data Time = Time
  { Time -> Date
date :: Date
  , Time -> Maybe OrgTime
tod  :: Maybe OrgTime
  }
  deriving (Time -> Time -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Time -> Time -> Bool
$c/= :: Time -> Time -> Bool
== :: Time -> Time -> Bool
$c== :: Time -> Time -> Bool
Eq, Int -> Time -> [Char] -> [Char]
[Time] -> [Char] -> [Char]
Time -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [Time] -> [Char] -> [Char]
$cshowList :: [Time] -> [Char] -> [Char]
show :: Time -> [Char]
$cshow :: Time -> [Char]
showsPrec :: Int -> Time -> [Char] -> [Char]
$cshowsPrec :: Int -> Time -> [Char] -> [Char]
Show)

-- | The time in HH:MM.
data TimeOfDay = HHMM Int Int
  deriving (TimeOfDay -> TimeOfDay -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TimeOfDay -> TimeOfDay -> Bool
$c/= :: TimeOfDay -> TimeOfDay -> Bool
== :: TimeOfDay -> TimeOfDay -> Bool
$c== :: TimeOfDay -> TimeOfDay -> Bool
Eq)

instance Show TimeOfDay where
  show :: TimeOfDay -> String
  show :: TimeOfDay -> [Char]
show (HHMM Int
h Int
m) = Int -> [Char]
pad Int
h forall a. Semigroup a => a -> a -> a
<> [Char]
":" forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
pad Int
m
   where
    pad :: Int -> String
    pad :: Int -> [Char]
pad Int
n = (if Int
n forall a. Ord a => a -> a -> Bool
<= Int
9 then [Char]
"0" else [Char]
"") forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
n

-- | The time—possibly as a span—in HH:MM format.
data OrgTime = MomentInTime TimeOfDay | TimeSpan TimeOfDay TimeOfDay
  deriving (OrgTime -> OrgTime -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OrgTime -> OrgTime -> Bool
$c/= :: OrgTime -> OrgTime -> Bool
== :: OrgTime -> OrgTime -> Bool
$c== :: OrgTime -> OrgTime -> Bool
Eq)

instance Show OrgTime where
  show :: OrgTime -> String
  show :: OrgTime -> [Char]
show (MomentInTime TimeOfDay
tod)  = forall a. Show a => a -> [Char]
show TimeOfDay
tod
  show (TimeSpan TimeOfDay
tod TimeOfDay
tod') = forall a. Show a => a -> [Char]
show TimeOfDay
tod forall a. Semigroup a => a -> a -> a
<> [Char]
"-" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show TimeOfDay
tod'

-- | Type for specifying exactly which day one wants.
data Date
  = Today
  | Tomorrow
  | Next DayOfWeek
    -- ^ This will __always__ show the next 'DayOfWeek' (e.g. calling
    -- 'Next Monday' on a Monday will result in getting the menu for the
    -- following Monday)
  | Date (Int, Maybe Int, Maybe Integer)
    -- ^ Manual date entry in the format DD [MM] [YYYY]
  deriving (Date -> Date -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Date -> Date -> Bool
$c/= :: Date -> Date -> Bool
== :: Date -> Date -> Bool
$c== :: Date -> Date -> Bool
Eq, Eq Date
Date -> Date -> Bool
Date -> Date -> Ordering
Date -> Date -> Date
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Date -> Date -> Date
$cmin :: Date -> Date -> Date
max :: Date -> Date -> Date
$cmax :: Date -> Date -> Date
>= :: Date -> Date -> Bool
$c>= :: Date -> Date -> Bool
> :: Date -> Date -> Bool
$c> :: Date -> Date -> Bool
<= :: Date -> Date -> Bool
$c<= :: Date -> Date -> Bool
< :: Date -> Date -> Bool
$c< :: Date -> Date -> Bool
compare :: Date -> Date -> Ordering
$ccompare :: Date -> Date -> Ordering
Ord, Int -> Date -> [Char] -> [Char]
[Date] -> [Char] -> [Char]
Date -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [Date] -> [Char] -> [Char]
$cshowList :: [Date] -> [Char] -> [Char]
show :: Date -> [Char]
$cshow :: Date -> [Char]
showsPrec :: Int -> Date -> [Char] -> [Char]
$cshowsPrec :: Int -> Date -> [Char] -> [Char]
Show)

toOrgFmt :: Maybe OrgTime -> Day -> String
toOrgFmt :: Maybe OrgTime -> Day -> [Char]
toOrgFmt Maybe OrgTime
tod Day
day =
  forall a. Monoid a => [a] -> a
mconcat [[Char]
"<", [Char]
isoDay, [Char]
" ", forall a. Int -> [a] -> [a]
take Int
3 forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show (Day -> DayOfWeek
dayOfWeek Day
day), [Char]
time, [Char]
">"]
 where
  [Char]
time   :: String = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" ((Char
' ' forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show) Maybe OrgTime
tod
#if MIN_VERSION_time(1, 9, 0)
  [Char]
isoDay :: String = forall t. ISO8601 t => t -> [Char]
iso8601Show Day
day
#else
  isoDay :: String = formatTime defaultTimeLocale (iso8601DateFormat Nothing) day
#endif

-- | Pretty print a 'Date' and an optional time to reflect the actual
-- date.
ppDate :: Time -> IO String
ppDate :: Time -> IO [Char]
ppDate Time{ Date
date :: Date
date :: Time -> Date
date, Maybe OrgTime
tod :: Maybe OrgTime
tod :: Time -> Maybe OrgTime
tod } = do
  UTCTime
curTime <- IO UTCTime
getCurrentTime
  let curDay :: Day
curDay      = UTCTime -> Day
utctDay UTCTime
curTime
      (Integer
y, Int
m, Int
_)   = Day -> (Integer, Int, Int)
toGregorian Day
curDay
      diffToDay :: DayOfWeek -> NominalDiffTime
diffToDay DayOfWeek
d = DayOfWeek -> DayOfWeek -> NominalDiffTime
diffBetween DayOfWeek
d (Day -> DayOfWeek
dayOfWeek Day
curDay)

  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe OrgTime -> Day -> [Char]
toOrgFmt Maybe OrgTime
tod forall a b. (a -> b) -> a -> b
$ case Date
date of
    Date
Today              -> Day
curDay
    Date
Tomorrow           -> UTCTime -> Day
utctDay forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> UTCTime -> UTCTime
addDays NominalDiffTime
1 UTCTime
curTime
    Next DayOfWeek
wday          -> UTCTime -> Day
utctDay forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> UTCTime -> UTCTime
addDays (DayOfWeek -> NominalDiffTime
diffToDay DayOfWeek
wday) UTCTime
curTime
    Date (Int
d, Maybe Int
mbM, Maybe Integer
mbY) -> Integer -> Int -> Int -> Day
fromGregorian (forall a. a -> Maybe a -> a
fromMaybe Integer
y Maybe Integer
mbY) (forall a. a -> Maybe a -> a
fromMaybe Int
m Maybe Int
mbM) Int
d
 where
  -- | Add a specified number of days to a 'UTCTime'.
  NominalDiffTime -> UTCTime -> UTCTime
addDays :: NominalDiffTime -> UTCTime -> UTCTime
    = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
* NominalDiffTime
nominalDay)

  -- | Evil enum hackery.
  diffBetween :: DayOfWeek -> DayOfWeek -> NominalDiffTime
  diffBetween :: DayOfWeek -> DayOfWeek -> NominalDiffTime
diffBetween DayOfWeek
d DayOfWeek
cur  -- we want to jump to @d@
    | DayOfWeek
d forall a. Eq a => a -> a -> Bool
== DayOfWeek
cur  = NominalDiffTime
7
    | Bool
otherwise = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a
abs forall a b. (a -> b) -> a -> b
$ (forall a. Enum a => a -> Int
fromEnum DayOfWeek
d forall a. Num a => a -> a -> a
- forall a. Enum a => a -> Int
fromEnum DayOfWeek
cur) forall a. Integral a => a -> a -> a
`mod` Int
7

-- Old GHC versions don't have a @time@ library new enough to have
-- this, so replicate it here for the moment.

dayOfWeek :: Day -> DayOfWeek
dayOfWeek :: Day -> DayOfWeek
dayOfWeek (ModifiedJulianDay Integer
d) = forall a. Enum a => Int -> a
toEnum forall a b. (a -> b) -> a -> b
$ forall a. Num a => Integer -> a
fromInteger forall a b. (a -> b) -> a -> b
$ Integer
d forall a. Num a => a -> a -> a
+ Integer
3

data DayOfWeek
  = Monday | Tuesday | Wednesday | Thursday | Friday | Saturday | Sunday
  deriving (DayOfWeek -> DayOfWeek -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DayOfWeek -> DayOfWeek -> Bool
$c/= :: DayOfWeek -> DayOfWeek -> Bool
== :: DayOfWeek -> DayOfWeek -> Bool
$c== :: DayOfWeek -> DayOfWeek -> Bool
Eq, Eq DayOfWeek
DayOfWeek -> DayOfWeek -> Bool
DayOfWeek -> DayOfWeek -> Ordering
DayOfWeek -> DayOfWeek -> DayOfWeek
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DayOfWeek -> DayOfWeek -> DayOfWeek
$cmin :: DayOfWeek -> DayOfWeek -> DayOfWeek
max :: DayOfWeek -> DayOfWeek -> DayOfWeek
$cmax :: DayOfWeek -> DayOfWeek -> DayOfWeek
>= :: DayOfWeek -> DayOfWeek -> Bool
$c>= :: DayOfWeek -> DayOfWeek -> Bool
> :: DayOfWeek -> DayOfWeek -> Bool
$c> :: DayOfWeek -> DayOfWeek -> Bool
<= :: DayOfWeek -> DayOfWeek -> Bool
$c<= :: DayOfWeek -> DayOfWeek -> Bool
< :: DayOfWeek -> DayOfWeek -> Bool
$c< :: DayOfWeek -> DayOfWeek -> Bool
compare :: DayOfWeek -> DayOfWeek -> Ordering
$ccompare :: DayOfWeek -> DayOfWeek -> Ordering
Ord, Int -> DayOfWeek -> [Char] -> [Char]
[DayOfWeek] -> [Char] -> [Char]
DayOfWeek -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [DayOfWeek] -> [Char] -> [Char]
$cshowList :: [DayOfWeek] -> [Char] -> [Char]
show :: DayOfWeek -> [Char]
$cshow :: DayOfWeek -> [Char]
showsPrec :: Int -> DayOfWeek -> [Char] -> [Char]
$cshowsPrec :: Int -> DayOfWeek -> [Char] -> [Char]
Show)

-- | \"Circular\", so for example @[Tuesday ..]@ gives an endless
-- sequence.  Also: 'fromEnum' gives [1 .. 7] for [Monday .. Sunday],
-- and 'toEnum' performs mod 7 to give a cycle of days.
instance Enum DayOfWeek where
  toEnum :: Int -> DayOfWeek
  toEnum :: Int -> DayOfWeek
toEnum Int
i = case forall a. Integral a => a -> a -> a
mod Int
i Int
7 of
    Int
0 -> DayOfWeek
Sunday
    Int
1 -> DayOfWeek
Monday
    Int
2 -> DayOfWeek
Tuesday
    Int
3 -> DayOfWeek
Wednesday
    Int
4 -> DayOfWeek
Thursday
    Int
5 -> DayOfWeek
Friday
    Int
_ -> DayOfWeek
Saturday

  fromEnum :: DayOfWeek -> Int
  fromEnum :: DayOfWeek -> Int
fromEnum = \case
    DayOfWeek
Monday    -> Int
1
    DayOfWeek
Tuesday   -> Int
2
    DayOfWeek
Wednesday -> Int
3
    DayOfWeek
Thursday  -> Int
4
    DayOfWeek
Friday    -> Int
5
    DayOfWeek
Saturday  -> Int
6
    DayOfWeek
Sunday    -> Int
7

------------------------------------------------------------------------
-- Note

-- | An @org-mode@ style note.
data Note
  = Scheduled String Time Priority
  | Deadline  String Time Priority
  | NormalMsg String      Priority
  deriving (Note -> Note -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Note -> Note -> Bool
$c/= :: Note -> Note -> Bool
== :: Note -> Note -> Bool
$c== :: Note -> Note -> Bool
Eq, Int -> Note -> [Char] -> [Char]
[Note] -> [Char] -> [Char]
Note -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [Note] -> [Char] -> [Char]
$cshowList :: [Note] -> [Char] -> [Char]
show :: Note -> [Char]
$cshow :: Note -> [Char]
showsPrec :: Int -> Note -> [Char] -> [Char]
$cshowsPrec :: Int -> Note -> [Char] -> [Char]
Show)

-- | An @org-mode@ style priority symbol[1]; e.g., something like
-- @[#A]@.  Note that this uses the standard org conventions: supported
-- priorities are @A@, @B@, and @C@, with @A@ being the highest.
-- Numerical priorities are not supported.
--
-- [1]: https://orgmode.org/manual/Priorities.html
data Priority = A | B | C | NoPriority
  deriving (Priority -> Priority -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Priority -> Priority -> Bool
$c/= :: Priority -> Priority -> Bool
== :: Priority -> Priority -> Bool
$c== :: Priority -> Priority -> Bool
Eq, Int -> Priority -> [Char] -> [Char]
[Priority] -> [Char] -> [Char]
Priority -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [Priority] -> [Char] -> [Char]
$cshowList :: [Priority] -> [Char] -> [Char]
show :: Priority -> [Char]
$cshow :: Priority -> [Char]
showsPrec :: Int -> Priority -> [Char] -> [Char]
$cshowsPrec :: Int -> Priority -> [Char] -> [Char]
Show)

-- | Pretty print a given 'Note'.
ppNote :: Clp -> String -> Note -> IO String
ppNote :: Clp -> [Char] -> Note -> IO [Char]
ppNote Clp
clp [Char]
todo = \case
  Scheduled [Char]
str Time
time Priority
prio -> [Char] -> [Char] -> Maybe Time -> Priority -> IO [Char]
mkLine [Char]
str [Char]
"SCHEDULED: " (forall a. a -> Maybe a
Just Time
time) Priority
prio
  Deadline  [Char]
str Time
time Priority
prio -> [Char] -> [Char] -> Maybe Time -> Priority -> IO [Char]
mkLine [Char]
str [Char]
"DEADLINE: "  (forall a. a -> Maybe a
Just Time
time) Priority
prio
  NormalMsg [Char]
str      Priority
prio -> [Char] -> [Char] -> Maybe Time -> Priority -> IO [Char]
mkLine [Char]
str [Char]
""            forall a. Maybe a
Nothing     Priority
prio
 where
  mkLine :: String -> String -> Maybe Time -> Priority -> IO String
  mkLine :: [Char] -> [Char] -> Maybe Time -> Priority -> IO [Char]
mkLine [Char]
str [Char]
sched Maybe Time
time Priority
prio = do
    [Char]
t <- case Maybe Time
time of
      Maybe Time
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
""
      Just Time
ti -> (([Char]
"\n  " forall a. Semigroup a => a -> a -> a
<> [Char]
sched) forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Time -> IO [Char]
ppDate Time
ti
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Char]
"* " forall a. Semigroup a => a -> a -> a
<> [Char]
todo forall a. Semigroup a => a -> a -> a
<> [Char]
priority forall a. Semigroup a => a -> a -> a
<> case Clp
clp of
      Body   [Char]
c -> forall a. Monoid a => [a] -> a
mconcat [[Char]
str, [Char]
t, [Char]
c]
      Header [Char]
c -> forall a. Monoid a => [a] -> a
mconcat [[Char]
"[[", [Char]
c, [Char]
"][", [Char]
str,[Char]
"]]", [Char]
t]
   where
    priority :: [Char]
priority = case Priority
prio of
      Priority
NoPriority -> [Char]
" "
      Priority
otherPrio  -> [Char]
" [#" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Priority
otherPrio forall a. Semigroup a => a -> a -> a
<> [Char]
"] "

------------------------------------------------------------------------
-- Note parsing

-- | Parse the given string into a 'Note'.
pInput :: String -> Maybe Note
pInput :: [Char] -> Maybe Note
pInput [Char]
inp = (forall a. Parser a -> [Char] -> Maybe a
`runParser` [Char]
inp) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Parser a] -> Parser a
choice forall a b. (a -> b) -> a -> b
$
  [ [Char] -> Time -> Priority -> Note
Scheduled forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Char] -> Parser [Char]
getLast [Char]
"+s" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser [Char]
" ") forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe Date -> Maybe OrgTime -> Parser Time
fixTime forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Maybe Date)
pDate forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe OrgTime)
pOrgTime) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Priority
pPriority
  , [Char] -> Time -> Priority -> Note
Deadline  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Char] -> Parser [Char]
getLast [Char]
"+d" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser [Char]
" ") forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe Date -> Maybe OrgTime -> Parser Time
fixTime forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Maybe Date)
pDate forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe OrgTime)
pOrgTime) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Priority
pPriority
  , do [Char]
s <- (Char -> Bool) -> Parser [Char]
munch1 (forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True)
       let ([Char]
s', [Char]
p) = forall a. Int -> [a] -> ([a], [a])
splitAt (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
s forall a. Num a => a -> a -> a
- Int
3) [Char]
s
       forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case [Char] -> Maybe Priority
tryPrio [Char]
p of
         Just Priority
prio -> [Char] -> Priority -> Note
NormalMsg (Int -> [Char] -> [Char]
dropStripEnd Int
0 [Char]
s') Priority
prio
         Maybe Priority
Nothing   -> [Char] -> Priority -> Note
NormalMsg [Char]
s                   Priority
NoPriority
  ]
 where
  fixTime :: Maybe Date -> Maybe OrgTime -> Parser Time
  fixTime :: Maybe Date -> Maybe OrgTime -> Parser Time
fixTime Maybe Date
d Maybe OrgTime
tod = case (Maybe Date
d, Maybe OrgTime
tod) of
    (Maybe Date
Nothing, Maybe OrgTime
Nothing) -> forall a. Monoid a => a
mempty                -- no day and no time
    (Maybe Date
Nothing, Just{})  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Date -> Maybe OrgTime -> Time
Time Date
Today Maybe OrgTime
tod) -- no day, but a time
    (Just Date
d', Maybe OrgTime
_)       -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Date -> Maybe OrgTime -> Time
Time Date
d'    Maybe OrgTime
tod) -- day given

  tryPrio :: String -> Maybe Priority
  tryPrio :: [Char] -> Maybe Priority
tryPrio [Char
' ', Char
'#', Char
x]
    | Char
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char]
"Aa" :: String) = forall a. a -> Maybe a
Just Priority
A
    | Char
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char]
"Bb" :: String) = forall a. a -> Maybe a
Just Priority
B
    | Char
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char]
"Cc" :: String) = forall a. a -> Maybe a
Just Priority
C
  tryPrio [Char]
_ = forall a. Maybe a
Nothing

  -- Trim whitespace at the end of a string after dropping some number
  -- of characters from it.
  dropStripEnd :: Int -> String -> String
  dropStripEnd :: Int -> [Char] -> [Char]
dropStripEnd Int
n = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
== Char
' ') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse

  getLast :: String -> Parser String
  getLast :: [Char] -> Parser [Char]
getLast [Char]
ptn =  Int -> [Char] -> [Char]
dropStripEnd (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
ptn) -- drop only the last pattern before stripping
              forall b c a. (b -> c) -> (a -> b) -> a -> c
.  forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
             forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a sep. Parser a -> Parser sep -> Parser [a]
endBy1 ([Char] -> Parser [Char]
go [Char]
"") (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
ptn)
   where
    go :: String -> Parser String
    go :: [Char] -> Parser [Char]
go [Char]
consumed = do
      [Char]
str  <- (Char -> Bool) -> Parser [Char]
munch  (forall a. Eq a => a -> a -> Bool
/= forall a. NonEmpty a -> a
NE.head (forall a. HasCallStack => [a] -> NonEmpty a
notEmpty [Char]
ptn))
      [Char]
word <- (Char -> Bool) -> Parser [Char]
munch1 (forall a. Eq a => a -> a -> Bool
/= Char
' ')
      forall a. a -> a -> Bool -> a
bool [Char] -> Parser [Char]
go forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
word forall a. Eq a => a -> a -> Bool
== [Char]
ptn) forall a b. (a -> b) -> a -> b
$ [Char]
consumed forall a. Semigroup a => a -> a -> a
<> [Char]
str forall a. Semigroup a => a -> a -> a
<> [Char]
word

-- | Parse a 'Priority'.
pPriority :: Parser Priority
pPriority :: Parser Priority
pPriority = forall a. a -> Parser a -> Parser a
option Priority
NoPriority forall a b. (a -> b) -> a -> b
$
  Parser ()
skipSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. [Parser a] -> Parser a
choice
    [ Parser [Char]
"#" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Char] -> Parser [Char]
foldCase [Char]
"a" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Priority
A
    , Parser [Char]
"#" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Char] -> Parser [Char]
foldCase [Char]
"b" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Priority
B
    , Parser [Char]
"#" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Char] -> Parser [Char]
foldCase [Char]
"c" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Priority
C
    ]

-- | Try to parse a 'Time'.
pOrgTime :: Parser (Maybe OrgTime)
pOrgTime :: Parser (Maybe OrgTime)
pOrgTime = forall a. a -> Parser a -> Parser a
option forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$
  forall open close a.
Parser open -> Parser close -> Parser a -> Parser a
between Parser ()
skipSpaces (forall (f :: * -> *) a. Functor f => f a -> f ()
void Parser [Char]
" " forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
eof) forall a b. (a -> b) -> a -> b
$
    forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [Parser a] -> Parser a
choice
      [ TimeOfDay -> TimeOfDay -> OrgTime
TimeSpan forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser TimeOfDay
pTimeOfDay forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (Parser [Char]
"--" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser [Char]
"-" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser [Char]
"–")) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser TimeOfDay
pTimeOfDay
      -- Org is not super smart around times with this syntax, so
      -- we pretend not to be as well.
      , do from :: TimeOfDay
from@(HHMM Int
h Int
m) <- Parser TimeOfDay
pTimeOfDay forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser [Char]
"+"
           Int
off <- Parser Int
pHour
           forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ TimeOfDay -> TimeOfDay -> OrgTime
TimeSpan TimeOfDay
from (Int -> Int -> TimeOfDay
HHMM (Int
h forall a. Num a => a -> a -> a
+ Int
off) Int
m)
      , TimeOfDay -> OrgTime
MomentInTime forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser TimeOfDay
pTimeOfDay
      ]
 where
  pTimeOfDay :: Parser TimeOfDay
  pTimeOfDay :: Parser TimeOfDay
pTimeOfDay = forall a. [Parser a] -> Parser a
choice
    [ Int -> Int -> TimeOfDay
HHMM forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Int
pHour forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser [Char]
":" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Int
pMinute -- HH:MM
    , Parser TimeOfDay
pHHMM                             -- HHMM
    , Int -> Int -> TimeOfDay
HHMM forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Int
pHour        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0  -- HH
    ]

  pHHMM :: Parser TimeOfDay
  pHHMM :: Parser TimeOfDay
pHHMM = do
    let getTwo :: Parser [Char]
getTwo = forall a. Int -> Parser a -> Parser [a]
count Int
2 ((Char -> Bool) -> Parser Char
satisfy Char -> Bool
isDigit)
    Int
hh <- forall a. Read a => [Char] -> a
read forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [Char]
getTwo
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
hh forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
hh forall a. Ord a => a -> a -> Bool
<= Int
23)
    Int
mm <- forall a. Read a => [Char] -> a
read forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [Char]
getTwo
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
mm forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
mm forall a. Ord a => a -> a -> Bool
<= Int
59)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Int -> Int -> TimeOfDay
HHMM Int
hh Int
mm

  Parser Int
pHour   :: Parser Int = Int -> Int -> Parser Int
pNumBetween Int
0 Int
23
  Parser Int
pMinute :: Parser Int = Int -> Int -> Parser Int
pNumBetween Int
0 Int
59

-- | Try to parse a 'Date'.
pDate :: Parser (Maybe Date)
pDate :: Parser (Maybe Date)
pDate = Parser ()
skipSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall a. [Parser a] -> Parser a
choice
  [ forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"tod" [Char]
"ay"    Date
Today
  , forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"tom" [Char]
"orrow" Date
Tomorrow
  , DayOfWeek -> Date
Next forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser DayOfWeek
pNext
  , (Int, Maybe Int, Maybe Integer) -> Date
Date forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Int, Maybe Int, Maybe Integer)
pDate'
  ])
 where
  Parser DayOfWeek
pNext :: Parser DayOfWeek = forall a. [Parser a] -> Parser a
choice
    [ forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"m"  [Char]
"onday"    DayOfWeek
Monday   , forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"tu" [Char]
"esday"  DayOfWeek
Tuesday
    , forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"w"  [Char]
"ednesday" DayOfWeek
Wednesday, forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"th" [Char]
"ursday" DayOfWeek
Thursday
    , forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"f"  [Char]
"riday"    DayOfWeek
Friday   , forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"sa" [Char]
"turday" DayOfWeek
Saturday
    , forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"su" [Char]
"nday"     DayOfWeek
Sunday
    ]

  numWithoutColon :: Parser Int
  numWithoutColon :: Parser Int
numWithoutColon = do
    Int
str <- Int -> Int -> Parser Int
pNumBetween Int
1 Int
12 -- month
    Char
c <- Parser Char
get
    if Char
c forall a. Eq a => a -> a -> Bool
== Char
':'
    then forall a. Parser a
pfail
    else forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
str

  pDate' :: Parser (Int, Maybe Int, Maybe Integer)
  pDate' :: Parser (Int, Maybe Int, Maybe Integer)
pDate' =
    (,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Int -> Parser Int
pNumBetween Int
1 Int
31 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (forall (f :: * -> *) a. Functor f => f a -> f ()
void Parser [Char]
" " forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
eof))  -- day
         forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser ()
skipSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. [Parser a] -> Parser a
choice
               [ forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"ja"  [Char]
"nuary"    Int
1 , forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"f"   [Char]
"ebruary" Int
2
               , forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"mar" [Char]
"ch"       Int
3 , forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"ap"  [Char]
"ril"     Int
4
               , forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"may" [Char]
""         Int
5 , forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"jun" [Char]
"e"       Int
6
               , forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"jul" [Char]
"y"        Int
7 , forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"au"  [Char]
"gust"    Int
8
               , forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"s"   [Char]
"eptember" Int
9 , forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"o"   [Char]
"ctober"  Int
10
               , forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"n"   [Char]
"ovember"  Int
11, forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"d"   [Char]
"ecember" Int
12
               , Parser Int
numWithoutColon
               ])
         forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser ()
skipSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. (Read a, Integral a) => Parser a
num forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Integer
i -> forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Integer
i forall a. Ord a => a -> a -> Bool
>= Integer
25) forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Integer
i)

  -- Parse a prefix and drop a potential suffix up to the next (space
  -- separated) word.  If successful, return @ret@.
  pPrefix :: String -> String -> a -> Parser a
  pPrefix :: forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
start (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower -> [Char]
leftover) a
ret = do
    forall (f :: * -> *) a. Functor f => f a -> f ()
void ([Char] -> Parser [Char]
foldCase [Char]
start)
    [Char]
l <- forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser [Char]
munch (forall a. Eq a => a -> a -> Bool
/= Char
' ')
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard ([Char]
l forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
leftover)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure a
ret

-- | Parse a number between @lo@ (inclusive) and @hi@ (inclusive).
pNumBetween :: Int -> Int -> Parser Int
pNumBetween :: Int -> Int -> Parser Int
pNumBetween Int
lo Int
hi = do
  Int
n <- forall a. (Read a, Integral a) => Parser a
num
  Int
n forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
n forall a. Ord a => a -> a -> Bool
>= Int
lo Bool -> Bool -> Bool
&& Int
n forall a. Ord a => a -> a -> Bool
<= Int
hi)

-- Parse the given string case insensitively.
foldCase :: String -> Parser String
foldCase :: [Char] -> Parser [Char]
foldCase = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\Char
c -> Char -> Parser Char
char (Char -> Char
toLower Char
c) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Char
char (Char -> Char
toUpper Char
c))

------------------------------------------------------------------------
-- File parsing

data Heading = Heading
  { Heading -> Natural
level       :: Natural
    -- ^ Level of the Org heading; i.e., the number of leading stars.
  , Heading -> [Char]
headingText :: String
    -- ^ The heading text without its level.
  }

-- | Naïvely parse an Org file.  At this point, only the headings are
-- parsed into a non-nested list (ignoring parent-child relations); no
-- further analysis is done on the individual lines themselves.
pOrgFile :: Parser [Heading]
pOrgFile :: Parser [Heading]
pOrgFile = forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser Heading
pHeading

pHeading :: Parser Heading
pHeading :: Parser Heading
pHeading = Parser ()
skipSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> do
  Natural
level       <- forall i a. Num i => [a] -> i
genericLength forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser [Char]
munch1 (forall a. Eq a => a -> a -> Bool
== Char
'*') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser [Char]
" "
  [Char]
headingText <- Parser [Char]
pLine
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser [Char]
pLine forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Char]
line -> forall (f :: * -> *). Alternative f => Bool -> f ()
guard ([Char] -> Bool
isNotHeading [Char]
line) forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [Char]
line) -- skip body
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Heading{Natural
[Char]
headingText :: [Char]
level :: Natural
level :: Natural
headingText :: [Char]
..}

pLine :: Parser String
pLine :: Parser [Char]
pLine = (Char -> Bool) -> Parser [Char]
munch (forall a. Eq a => a -> a -> Bool
/= Char
'\n') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser [Char]
"\n"

isNotHeading :: String -> Bool
isNotHeading :: [Char] -> Bool
isNotHeading [Char]
str = case forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
/= Char
'*') [Char]
str of
  ([Char]
"", [Char]
_)       -> Bool
True
  ([Char]
_ , Char
' ' : [Char]
_) -> Bool
False
  ([Char], [Char])
_             -> Bool
True