{-# 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 ([Char] -> OrgMode) -> X [Char] -> X OrgMode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> X [Char]
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 :: OrgMode -> [Char]
todoHeader :: [Char]
todoHeader, [Char]
orgFile :: OrgMode -> [Char]
orgFile :: [Char]
orgFile, ClipboardSupport
clpSupport :: OrgMode -> ClipboardSupport
clpSupport :: ClipboardSupport
clpSupport } =
    [[Char]] -> [Char]
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 = (X Bool -> X ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (X Bool -> X ()) -> (OrgMode -> X Bool) -> OrgMode -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPConfig -> OrgMode -> X Bool
mkOrgPrompt XPConfig
xpc (OrgMode -> X ()) -> X OrgMode -> X ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (X OrgMode -> X ())
-> ([Char] -> [Char] -> X OrgMode) -> [Char] -> [Char] -> X ()
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 = (X Bool -> X ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (X Bool -> X ()) -> (OrgMode -> X Bool) -> OrgMode -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPConfig -> OrgMode -> X Bool
mkOrgPrompt XPConfig
xpc (OrgMode -> X ()) -> X OrgMode -> X ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (X OrgMode -> X ())
-> ([Char] -> [Char] -> X OrgMode) -> [Char] -> [Char] -> X ()
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 <- IO [Char] -> X [Char]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO [Char] -> X [Char]) -> IO [Char] -> X [Char]
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 [Char] -> IO () -> IO [Char]
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ([Char]
contents [Char] -> IO () -> IO ()
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
  Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
notCancelled (X () -> X ()) -> X () -> X ()
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.
    Maybe [Heading] -> ([Heading] -> X ()) -> X ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (Parser [Heading] -> [Char] -> Maybe [Heading]
forall a. Parser a -> [Char] -> Maybe a
runParser Parser [Heading]
pOrgFile [Char]
fileContents) (([Heading] -> X ()) -> X ()) -> ([Heading] -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \[Heading]
headings ->
      RefilePrompt
-> XPConfig
-> ComplFunction
-> ([Char] -> X [Char])
-> X (Maybe [Char])
forall p a.
XPrompt p =>
p -> XPConfig -> ComplFunction -> ([Char] -> X a) -> X (Maybe a)
mkXPromptWithReturn RefilePrompt
Refile XPConfig
xpc ([Heading] -> ComplFunction
completeHeadings [Heading]
headings) [Char] -> X [Char]
forall a. a -> X a
forall (f :: * -> *) a. Applicative f => a -> f a
pure X (Maybe [Char]) -> (Maybe [Char] -> X ()) -> X ()
forall a b. X a -> (a -> X b) -> X b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe [Char]
Nothing     -> () -> X ()
forall a. a -> X a
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 ([[Char]] -> ComplFunction)
-> ([Heading] -> [[Char]]) -> [Heading] -> ComplFunction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Heading -> [Char]) -> [Heading] -> [[Char]]
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
  Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
notCancelled (X () -> X ()) -> X () -> X ()
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 :: OrgMode -> [Char]
todoHeader :: [Char]
todoHeader, [Char]
orgFile :: OrgMode -> [Char]
orgFile :: [Char]
orgFile, ClipboardSupport
clpSupport :: OrgMode -> ClipboardSupport
clpSupport :: ClipboardSupport
clpSupport } =
  Maybe () -> Bool
forall a. Maybe a -> Bool
isJust (Maybe () -> Bool) -> X (Maybe ()) -> X Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OrgMode
-> XPConfig -> ComplFunction -> ([Char] -> X ()) -> X (Maybe ())
forall p a.
XPrompt p =>
p -> XPConfig -> ComplFunction -> ([Char] -> X a) -> X (Maybe a)
mkXPromptWithReturn OrgMode
oc XPConfig
xpc (IO [[Char]] -> ComplFunction
forall a b. a -> b -> a
const ([[Char]] -> IO [[Char]]
forall a. a -> IO a
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 = IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ do
    Clp
clpStr <- case ClipboardSupport
clpSupport of
      ClipboardSupport
NoClpSupport     -> Clp -> IO Clp
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Clp -> IO Clp) -> Clp -> IO Clp
forall a b. (a -> b) -> a -> b
$ [Char] -> Clp
Body [Char]
""
      ClipboardSupport
PrimarySelection -> do
        [Char]
sel <- IO [Char]
forall (m :: * -> *). MonadIO m => m [Char]
getSelection
        Clp -> IO Clp
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Clp -> IO Clp) -> Clp -> IO Clp
forall a b. (a -> b) -> a -> b
$ if   ([Char] -> Bool) -> [[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
sel) [[Char]
"http://", [Char]
"https://"]
               then [Char] -> Clp
Header [Char]
sel
               else [Char] -> Clp
Body   ([Char] -> Clp) -> [Char] -> Clp
forall a b. (a -> b) -> a -> b
$ [Char]
"\n " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
sel

    [Char] -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
withFile [Char]
orgFile IOMode
AppendMode ((Handle -> IO ()) -> IO ())
-> ([Char] -> Handle -> IO ()) -> [Char] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Handle -> [Char] -> IO ()) -> [Char] -> Handle -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Handle -> [Char] -> IO ()
hPutStrLn
      ([Char] -> IO ()) -> ([Char] -> IO [Char]) -> [Char] -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< IO [Char] -> (Note -> IO [Char]) -> Maybe Note -> IO [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> IO [Char]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"") (Clp -> [Char] -> Note -> IO [Char]
ppNote Clp
clpStr [Char]
todoHeader) (Maybe Note -> IO [Char])
-> ([Char] -> Maybe Note) -> [Char] -> IO [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Maybe Note
pInput
        ([Char] -> IO ()) -> [Char] -> IO ()
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 (X ([Char] -> [Char]) -> X ()) -> X ([Char] -> [Char]) -> X ()
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" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
fp
                     , [Char]
"end-of-buffer"
                     , [Char]
"org-refile nil nil"
                         [Char] -> [Char] -> [Char]
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"
                                                    [Char] -> [Char] -> [Char]
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
(Time -> Time -> Bool) -> (Time -> Time -> Bool) -> Eq Time
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Time -> Time -> Bool
== :: Time -> Time -> Bool
$c/= :: Time -> Time -> Bool
/= :: Time -> Time -> Bool
Eq, Int -> Time -> [Char] -> [Char]
[Time] -> [Char] -> [Char]
Time -> [Char]
(Int -> Time -> [Char] -> [Char])
-> (Time -> [Char]) -> ([Time] -> [Char] -> [Char]) -> Show Time
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Time -> [Char] -> [Char]
showsPrec :: Int -> Time -> [Char] -> [Char]
$cshow :: Time -> [Char]
show :: Time -> [Char]
$cshowList :: [Time] -> [Char] -> [Char]
showList :: [Time] -> [Char] -> [Char]
Show)

-- | The time in HH:MM.
data TimeOfDay = HHMM Int Int
  deriving (TimeOfDay -> TimeOfDay -> Bool
(TimeOfDay -> TimeOfDay -> Bool)
-> (TimeOfDay -> TimeOfDay -> Bool) -> Eq TimeOfDay
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TimeOfDay -> TimeOfDay -> Bool
== :: TimeOfDay -> TimeOfDay -> Bool
$c/= :: TimeOfDay -> TimeOfDay -> Bool
/= :: 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 [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
":" [Char] -> [Char] -> [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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
9 then [Char]
"0" else [Char]
"") [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
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
(OrgTime -> OrgTime -> Bool)
-> (OrgTime -> OrgTime -> Bool) -> Eq OrgTime
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OrgTime -> OrgTime -> Bool
== :: OrgTime -> OrgTime -> Bool
$c/= :: OrgTime -> OrgTime -> Bool
/= :: OrgTime -> OrgTime -> Bool
Eq)

instance Show OrgTime where
  show :: OrgTime -> String
  show :: OrgTime -> [Char]
show (MomentInTime TimeOfDay
tod)  = TimeOfDay -> [Char]
forall a. Show a => a -> [Char]
show TimeOfDay
tod
  show (TimeSpan TimeOfDay
tod TimeOfDay
tod') = TimeOfDay -> [Char]
forall a. Show a => a -> [Char]
show TimeOfDay
tod [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"-" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> TimeOfDay -> [Char]
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
(Date -> Date -> Bool) -> (Date -> Date -> Bool) -> Eq Date
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Date -> Date -> Bool
== :: Date -> Date -> Bool
$c/= :: Date -> Date -> Bool
/= :: Date -> Date -> Bool
Eq, Eq Date
Eq Date =>
(Date -> Date -> Ordering)
-> (Date -> Date -> Bool)
-> (Date -> Date -> Bool)
-> (Date -> Date -> Bool)
-> (Date -> Date -> Bool)
-> (Date -> Date -> Date)
-> (Date -> Date -> Date)
-> Ord 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
$ccompare :: Date -> Date -> Ordering
compare :: Date -> Date -> Ordering
$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
>= :: Date -> Date -> Bool
$cmax :: Date -> Date -> Date
max :: Date -> Date -> Date
$cmin :: Date -> Date -> Date
min :: Date -> Date -> Date
Ord, Int -> Date -> [Char] -> [Char]
[Date] -> [Char] -> [Char]
Date -> [Char]
(Int -> Date -> [Char] -> [Char])
-> (Date -> [Char]) -> ([Date] -> [Char] -> [Char]) -> Show Date
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Date -> [Char] -> [Char]
showsPrec :: Int -> Date -> [Char] -> [Char]
$cshow :: Date -> [Char]
show :: Date -> [Char]
$cshowList :: [Date] -> [Char] -> [Char]
showList :: [Date] -> [Char] -> [Char]
Show)

toOrgFmt :: Maybe OrgTime -> Day -> String
toOrgFmt :: Maybe OrgTime -> Day -> [Char]
toOrgFmt Maybe OrgTime
tod Day
day =
  [[Char]] -> [Char]
forall a. Monoid a => [a] -> a
mconcat [[Char]
"<", [Char]
isoDay, [Char]
" ", Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take Int
3 ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ DayOfWeek -> [Char]
forall a. Show a => a -> [Char]
show (Day -> DayOfWeek
dayOfWeek Day
day), [Char]
time, [Char]
">"]
 where
  [Char]
time   :: String = [Char] -> (OrgTime -> [Char]) -> Maybe OrgTime -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" ((Char
' ' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:) ([Char] -> [Char]) -> (OrgTime -> [Char]) -> OrgTime -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OrgTime -> [Char]
forall a. Show a => a -> [Char]
show) Maybe OrgTime
tod
#if MIN_VERSION_time(1, 9, 0)
  [Char]
isoDay :: String = Day -> [Char]
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 :: Time -> Date
date :: Date
date, Maybe OrgTime
tod :: Time -> Maybe OrgTime
tod :: 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)

  [Char] -> IO [Char]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> IO [Char]) -> (Day -> [Char]) -> Day -> IO [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe OrgTime -> Day -> [Char]
toOrgFmt Maybe OrgTime
tod (Day -> IO [Char]) -> Day -> IO [Char]
forall a b. (a -> b) -> a -> b
$ case Date
date of
    Date
Today              -> Day
curDay
    Date
Tomorrow           -> UTCTime -> Day
utctDay (UTCTime -> Day) -> UTCTime -> Day
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> UTCTime -> UTCTime
addDays NominalDiffTime
1 UTCTime
curTime
    Next DayOfWeek
wday          -> UTCTime -> Day
utctDay (UTCTime -> Day) -> UTCTime -> Day
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 (Integer -> Maybe Integer -> Integer
forall a. a -> Maybe a -> a
fromMaybe Integer
y Maybe Integer
mbY) (Int -> Maybe Int -> Int
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 (NominalDiffTime -> UTCTime -> UTCTime)
-> (NominalDiffTime -> NominalDiffTime)
-> NominalDiffTime
-> UTCTime
-> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NominalDiffTime -> NominalDiffTime -> NominalDiffTime
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 DayOfWeek -> DayOfWeek -> Bool
forall a. Eq a => a -> a -> Bool
== DayOfWeek
cur  = NominalDiffTime
7
    | Bool
otherwise = Int -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> NominalDiffTime) -> (Int -> Int) -> Int -> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int
forall a. Num a => a -> a
abs (Int -> NominalDiffTime) -> Int -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ (DayOfWeek -> Int
forall a. Enum a => a -> Int
fromEnum DayOfWeek
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- DayOfWeek -> Int
forall a. Enum a => a -> Int
fromEnum DayOfWeek
cur) Int -> Int -> Int
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) = Int -> DayOfWeek
forall a. Enum a => Int -> a
toEnum (Int -> DayOfWeek) -> Int -> DayOfWeek
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Integer
d Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
3

data DayOfWeek
  = Monday | Tuesday | Wednesday | Thursday | Friday | Saturday | Sunday
  deriving (DayOfWeek -> DayOfWeek -> Bool
(DayOfWeek -> DayOfWeek -> Bool)
-> (DayOfWeek -> DayOfWeek -> Bool) -> Eq DayOfWeek
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DayOfWeek -> DayOfWeek -> Bool
== :: DayOfWeek -> DayOfWeek -> Bool
$c/= :: DayOfWeek -> DayOfWeek -> Bool
/= :: DayOfWeek -> DayOfWeek -> Bool
Eq, Eq DayOfWeek
Eq DayOfWeek =>
(DayOfWeek -> DayOfWeek -> Ordering)
-> (DayOfWeek -> DayOfWeek -> Bool)
-> (DayOfWeek -> DayOfWeek -> Bool)
-> (DayOfWeek -> DayOfWeek -> Bool)
-> (DayOfWeek -> DayOfWeek -> Bool)
-> (DayOfWeek -> DayOfWeek -> DayOfWeek)
-> (DayOfWeek -> DayOfWeek -> DayOfWeek)
-> Ord 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
$ccompare :: DayOfWeek -> DayOfWeek -> Ordering
compare :: DayOfWeek -> DayOfWeek -> Ordering
$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
>= :: DayOfWeek -> DayOfWeek -> Bool
$cmax :: DayOfWeek -> DayOfWeek -> DayOfWeek
max :: DayOfWeek -> DayOfWeek -> DayOfWeek
$cmin :: DayOfWeek -> DayOfWeek -> DayOfWeek
min :: DayOfWeek -> DayOfWeek -> DayOfWeek
Ord, Int -> DayOfWeek -> [Char] -> [Char]
[DayOfWeek] -> [Char] -> [Char]
DayOfWeek -> [Char]
(Int -> DayOfWeek -> [Char] -> [Char])
-> (DayOfWeek -> [Char])
-> ([DayOfWeek] -> [Char] -> [Char])
-> Show DayOfWeek
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> DayOfWeek -> [Char] -> [Char]
showsPrec :: Int -> DayOfWeek -> [Char] -> [Char]
$cshow :: DayOfWeek -> [Char]
show :: DayOfWeek -> [Char]
$cshowList :: [DayOfWeek] -> [Char] -> [Char]
showList :: [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 Int -> Int -> Int
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
(Note -> Note -> Bool) -> (Note -> Note -> Bool) -> Eq Note
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Note -> Note -> Bool
== :: Note -> Note -> Bool
$c/= :: Note -> Note -> Bool
/= :: Note -> Note -> Bool
Eq, Int -> Note -> [Char] -> [Char]
[Note] -> [Char] -> [Char]
Note -> [Char]
(Int -> Note -> [Char] -> [Char])
-> (Note -> [Char]) -> ([Note] -> [Char] -> [Char]) -> Show Note
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Note -> [Char] -> [Char]
showsPrec :: Int -> Note -> [Char] -> [Char]
$cshow :: Note -> [Char]
show :: Note -> [Char]
$cshowList :: [Note] -> [Char] -> [Char]
showList :: [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
(Priority -> Priority -> Bool)
-> (Priority -> Priority -> Bool) -> Eq Priority
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Priority -> Priority -> Bool
== :: Priority -> Priority -> Bool
$c/= :: Priority -> Priority -> Bool
/= :: Priority -> Priority -> Bool
Eq, Int -> Priority -> [Char] -> [Char]
[Priority] -> [Char] -> [Char]
Priority -> [Char]
(Int -> Priority -> [Char] -> [Char])
-> (Priority -> [Char])
-> ([Priority] -> [Char] -> [Char])
-> Show Priority
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Priority -> [Char] -> [Char]
showsPrec :: Int -> Priority -> [Char] -> [Char]
$cshow :: Priority -> [Char]
show :: Priority -> [Char]
$cshowList :: [Priority] -> [Char] -> [Char]
showList :: [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: " (Time -> Maybe Time
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: "  (Time -> Maybe Time
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]
""            Maybe Time
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 -> [Char] -> IO [Char]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
""
      Just Time
ti -> (([Char]
"\n  " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
sched) [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>) ([Char] -> [Char]) -> IO [Char] -> IO [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Time -> IO [Char]
ppDate Time
ti
    [Char] -> IO [Char]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"* " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
todo [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
priority [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> case Clp
clp of
      Body   [Char]
c -> [[Char]] -> [Char]
forall a. Monoid a => [a] -> a
mconcat [[Char]
str, [Char]
t, [Char]
c]
      Header [Char]
c -> [[Char]] -> [Char]
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]
" [#" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Priority -> [Char]
forall a. Show a => a -> [Char]
show Priority
otherPrio [Char] -> [Char] -> [Char]
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 = (Parser Note -> [Char] -> Maybe Note
forall a. Parser a -> [Char] -> Maybe a
`runParser` [Char]
inp) (Parser Note -> Maybe Note)
-> ([Parser Note] -> Parser Note) -> [Parser Note] -> Maybe Note
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Parser Note] -> Parser Note
forall a. [Parser a] -> Parser a
choice ([Parser Note] -> Maybe Note) -> [Parser Note] -> Maybe Note
forall a b. (a -> b) -> a -> b
$
  [ [Char] -> Time -> Priority -> Note
Scheduled ([Char] -> Time -> Priority -> Note)
-> Parser [Char] -> Parser (Time -> Priority -> Note)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Char] -> Parser [Char]
getLast [Char]
"+s" Parser [Char] -> Parser [Char] -> Parser [Char]
forall a b. Parser a -> Parser b -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser [Char]
" ") Parser (Time -> Priority -> Note)
-> Parser Time -> Parser (Priority -> Note)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Parser Time) -> Parser Time
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe Date -> Maybe OrgTime -> Parser Time
fixTime (Maybe Date -> Maybe OrgTime -> Parser Time)
-> Parser (Maybe Date) -> Parser (Maybe OrgTime -> Parser Time)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Maybe Date)
pDate Parser (Maybe OrgTime -> Parser Time)
-> Parser (Maybe OrgTime) -> Parser (Parser Time)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe OrgTime)
pOrgTime) Parser (Priority -> Note) -> Parser Priority -> Parser Note
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Priority
pPriority
  , [Char] -> Time -> Priority -> Note
Deadline  ([Char] -> Time -> Priority -> Note)
-> Parser [Char] -> Parser (Time -> Priority -> Note)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Char] -> Parser [Char]
getLast [Char]
"+d" Parser [Char] -> Parser [Char] -> Parser [Char]
forall a b. Parser a -> Parser b -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser [Char]
" ") Parser (Time -> Priority -> Note)
-> Parser Time -> Parser (Priority -> Note)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Parser Time) -> Parser Time
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe Date -> Maybe OrgTime -> Parser Time
fixTime (Maybe Date -> Maybe OrgTime -> Parser Time)
-> Parser (Maybe Date) -> Parser (Maybe OrgTime -> Parser Time)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Maybe Date)
pDate Parser (Maybe OrgTime -> Parser Time)
-> Parser (Maybe OrgTime) -> Parser (Parser Time)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe OrgTime)
pOrgTime) Parser (Priority -> Note) -> Parser Priority -> Parser Note
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Priority
pPriority
  , do [Char]
s <- (Char -> Bool) -> Parser [Char]
munch1 (Bool -> Char -> Bool
forall a. a -> Char -> a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True)
       let ([Char]
s', [Char]
p) = Int -> [Char] -> ([Char], [Char])
forall a. Int -> [a] -> ([a], [a])
splitAt ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3) [Char]
s
       Note -> Parser Note
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Note -> Parser Note) -> Note -> Parser Note
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) -> Parser Time
forall a. Monoid a => a
mempty                -- no day and no time
    (Maybe Date
Nothing, Just{})  -> Time -> Parser Time
forall a. a -> Parser a
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
_)       -> Time -> Parser Time
forall a. a -> Parser a
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 Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char]
"Aa" :: String) = Priority -> Maybe Priority
forall a. a -> Maybe a
Just Priority
A
    | Char
x Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char]
"Bb" :: String) = Priority -> Maybe Priority
forall a. a -> Maybe a
Just Priority
B
    | Char
x Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char]
"Cc" :: String) = Priority -> Maybe Priority
forall a. a -> Maybe a
Just Priority
C
  tryPrio [Char]
_ = Maybe Priority
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 = [Char] -> [Char]
forall a. [a] -> [a]
reverse ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
n ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
forall a. [a] -> [a]
reverse

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

-- | Parse a 'Priority'.
pPriority :: Parser Priority
pPriority :: Parser Priority
pPriority = Priority -> Parser Priority -> Parser Priority
forall a. a -> Parser a -> Parser a
option Priority
NoPriority (Parser Priority -> Parser Priority)
-> Parser Priority -> Parser Priority
forall a b. (a -> b) -> a -> b
$
  Parser ()
skipSpaces Parser () -> Parser Priority -> Parser Priority
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Parser Priority] -> Parser Priority
forall a. [Parser a] -> Parser a
choice
    [ Parser [Char]
"#" Parser [Char] -> Parser [Char] -> Parser [Char]
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Char] -> Parser [Char]
foldCase [Char]
"a" Parser [Char] -> Priority -> Parser Priority
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Priority
A
    , Parser [Char]
"#" Parser [Char] -> Parser [Char] -> Parser [Char]
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Char] -> Parser [Char]
foldCase [Char]
"b" Parser [Char] -> Priority -> Parser Priority
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Priority
B
    , Parser [Char]
"#" Parser [Char] -> Parser [Char] -> Parser [Char]
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Char] -> Parser [Char]
foldCase [Char]
"c" Parser [Char] -> Priority -> Parser Priority
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 = Maybe OrgTime -> Parser (Maybe OrgTime) -> Parser (Maybe OrgTime)
forall a. a -> Parser a -> Parser a
option Maybe OrgTime
forall a. Maybe a
Nothing (Parser (Maybe OrgTime) -> Parser (Maybe OrgTime))
-> Parser (Maybe OrgTime) -> Parser (Maybe OrgTime)
forall a b. (a -> b) -> a -> b
$
  Parser ()
-> Parser () -> Parser (Maybe OrgTime) -> Parser (Maybe OrgTime)
forall open close a.
Parser open -> Parser close -> Parser a -> Parser a
between Parser ()
skipSpaces (Parser [Char] -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Parser [Char]
" " Parser () -> Parser () -> Parser ()
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
eof) (Parser (Maybe OrgTime) -> Parser (Maybe OrgTime))
-> Parser (Maybe OrgTime) -> Parser (Maybe OrgTime)
forall a b. (a -> b) -> a -> b
$
    OrgTime -> Maybe OrgTime
forall a. a -> Maybe a
Just (OrgTime -> Maybe OrgTime)
-> Parser OrgTime -> Parser (Maybe OrgTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Parser OrgTime] -> Parser OrgTime
forall a. [Parser a] -> Parser a
choice
      [ TimeOfDay -> TimeOfDay -> OrgTime
TimeSpan (TimeOfDay -> TimeOfDay -> OrgTime)
-> Parser TimeOfDay -> Parser (TimeOfDay -> OrgTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser TimeOfDay
pTimeOfDay Parser TimeOfDay -> Parser [Char] -> Parser TimeOfDay
forall a b. Parser a -> Parser b -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (Parser [Char]
"--" Parser [Char] -> Parser [Char] -> Parser [Char]
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser [Char]
"-" Parser [Char] -> Parser [Char] -> Parser [Char]
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser [Char]
"–")) Parser (TimeOfDay -> OrgTime) -> Parser TimeOfDay -> Parser OrgTime
forall a b. Parser (a -> b) -> Parser a -> Parser b
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 Parser TimeOfDay -> Parser [Char] -> Parser TimeOfDay
forall a b. Parser a -> Parser b -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser [Char]
"+"
           Int
off <- Parser Int
pHour
           OrgTime -> Parser OrgTime
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OrgTime -> Parser OrgTime) -> OrgTime -> Parser OrgTime
forall a b. (a -> b) -> a -> b
$ TimeOfDay -> TimeOfDay -> OrgTime
TimeSpan TimeOfDay
from (Int -> Int -> TimeOfDay
HHMM (Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
off) Int
m)
      , TimeOfDay -> OrgTime
MomentInTime (TimeOfDay -> OrgTime) -> Parser TimeOfDay -> Parser OrgTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser TimeOfDay
pTimeOfDay
      ]
 where
  pTimeOfDay :: Parser TimeOfDay
  pTimeOfDay :: Parser TimeOfDay
pTimeOfDay = [Parser TimeOfDay] -> Parser TimeOfDay
forall a. [Parser a] -> Parser a
choice
    [ Int -> Int -> TimeOfDay
HHMM (Int -> Int -> TimeOfDay)
-> Parser Int -> Parser (Int -> TimeOfDay)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Int
pHour Parser (Int -> TimeOfDay)
-> Parser [Char] -> Parser (Int -> TimeOfDay)
forall a b. Parser a -> Parser b -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser [Char]
":" Parser (Int -> TimeOfDay) -> Parser Int -> Parser TimeOfDay
forall a b. Parser (a -> b) -> Parser a -> Parser b
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 (Int -> Int -> TimeOfDay)
-> Parser Int -> Parser (Int -> TimeOfDay)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Int
pHour        Parser (Int -> TimeOfDay) -> Parser Int -> Parser TimeOfDay
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Parser Int
forall a. a -> Parser a
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 = Int -> Parser Char -> Parser [Char]
forall a. Int -> Parser a -> Parser [a]
count Int
2 ((Char -> Bool) -> Parser Char
satisfy Char -> Bool
isDigit)
    Int
hh <- [Char] -> Int
forall a. Read a => [Char] -> a
read ([Char] -> Int) -> Parser [Char] -> Parser Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [Char]
getTwo
    Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
hh Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
hh Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
23)
    Int
mm <- [Char] -> Int
forall a. Read a => [Char] -> a
read ([Char] -> Int) -> Parser [Char] -> Parser Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [Char]
getTwo
    Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
mm Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
mm Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
59)
    TimeOfDay -> Parser TimeOfDay
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TimeOfDay -> Parser TimeOfDay) -> TimeOfDay -> Parser TimeOfDay
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 Parser () -> Parser (Maybe Date) -> Parser (Maybe Date)
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Date -> Parser (Maybe Date)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ([Parser Date] -> Parser Date
forall a. [Parser a] -> Parser a
choice
  [ [Char] -> [Char] -> Date -> Parser Date
forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"tod" [Char]
"ay"    Date
Today
  , [Char] -> [Char] -> Date -> Parser Date
forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"tom" [Char]
"orrow" Date
Tomorrow
  , DayOfWeek -> Date
Next (DayOfWeek -> Date) -> Parser DayOfWeek -> Parser Date
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser DayOfWeek
pNext
  , (Int, Maybe Int, Maybe Integer) -> Date
Date ((Int, Maybe Int, Maybe Integer) -> Date)
-> Parser (Int, Maybe Int, Maybe Integer) -> Parser 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 = [Parser DayOfWeek] -> Parser DayOfWeek
forall a. [Parser a] -> Parser a
choice
    [ [Char] -> [Char] -> DayOfWeek -> Parser DayOfWeek
forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"m"  [Char]
"onday"    DayOfWeek
Monday   , [Char] -> [Char] -> DayOfWeek -> Parser DayOfWeek
forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"tu" [Char]
"esday"  DayOfWeek
Tuesday
    , [Char] -> [Char] -> DayOfWeek -> Parser DayOfWeek
forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"w"  [Char]
"ednesday" DayOfWeek
Wednesday, [Char] -> [Char] -> DayOfWeek -> Parser DayOfWeek
forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"th" [Char]
"ursday" DayOfWeek
Thursday
    , [Char] -> [Char] -> DayOfWeek -> Parser DayOfWeek
forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"f"  [Char]
"riday"    DayOfWeek
Friday   , [Char] -> [Char] -> DayOfWeek -> Parser DayOfWeek
forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"sa" [Char]
"turday" DayOfWeek
Saturday
    , [Char] -> [Char] -> DayOfWeek -> Parser DayOfWeek
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 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':'
    then Parser Int
forall a. Parser a
pfail
    else Int -> Parser Int
forall a. a -> Parser a
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' =
    (,,) (Int
 -> Maybe Int -> Maybe Integer -> (Int, Maybe Int, Maybe Integer))
-> Parser Int
-> Parser
     (Maybe Int -> Maybe Integer -> (Int, Maybe Int, Maybe Integer))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Int -> Parser Int
pNumBetween Int
1 Int
31 Parser Int -> Parser () -> Parser Int
forall a b. Parser a -> Parser b -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (Parser [Char] -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Parser [Char]
" " Parser () -> Parser () -> Parser ()
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
eof))  -- day
         Parser
  (Maybe Int -> Maybe Integer -> (Int, Maybe Int, Maybe Integer))
-> Parser (Maybe Int)
-> Parser (Maybe Integer -> (Int, Maybe Int, Maybe Integer))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Int -> Parser (Maybe Int)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser ()
skipSpaces Parser () -> Parser Int -> Parser Int
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Parser Int] -> Parser Int
forall a. [Parser a] -> Parser a
choice
               [ [Char] -> [Char] -> Int -> Parser Int
forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"ja"  [Char]
"nuary"    Int
1 , [Char] -> [Char] -> Int -> Parser Int
forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"f"   [Char]
"ebruary" Int
2
               , [Char] -> [Char] -> Int -> Parser Int
forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"mar" [Char]
"ch"       Int
3 , [Char] -> [Char] -> Int -> Parser Int
forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"ap"  [Char]
"ril"     Int
4
               , [Char] -> [Char] -> Int -> Parser Int
forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"may" [Char]
""         Int
5 , [Char] -> [Char] -> Int -> Parser Int
forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"jun" [Char]
"e"       Int
6
               , [Char] -> [Char] -> Int -> Parser Int
forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"jul" [Char]
"y"        Int
7 , [Char] -> [Char] -> Int -> Parser Int
forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"au"  [Char]
"gust"    Int
8
               , [Char] -> [Char] -> Int -> Parser Int
forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"s"   [Char]
"eptember" Int
9 , [Char] -> [Char] -> Int -> Parser Int
forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"o"   [Char]
"ctober"  Int
10
               , [Char] -> [Char] -> Int -> Parser Int
forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"n"   [Char]
"ovember"  Int
11, [Char] -> [Char] -> Int -> Parser Int
forall a. [Char] -> [Char] -> a -> Parser a
pPrefix [Char]
"d"   [Char]
"ecember" Int
12
               , Parser Int
numWithoutColon
               ])
         Parser (Maybe Integer -> (Int, Maybe Int, Maybe Integer))
-> Parser (Maybe Integer) -> Parser (Int, Maybe Int, Maybe Integer)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Integer -> Parser (Maybe Integer)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser ()
skipSpaces Parser () -> Parser Integer -> Parser Integer
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Integer
forall a. (Read a, Integral a) => Parser a
num Parser Integer -> (Integer -> Parser Integer) -> Parser Integer
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Integer
i -> Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
25) Parser () -> Integer -> Parser Integer
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 ((Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower -> [Char]
leftover) a
ret = do
    Parser [Char] -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ([Char] -> Parser [Char]
foldCase [Char]
start)
    [Char]
l <- (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower ([Char] -> [Char]) -> Parser [Char] -> Parser [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser [Char]
munch (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ')
    Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ([Char]
l [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
leftover)
    a -> Parser a
forall a. a -> Parser a
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 <- Parser Int
forall a. (Read a, Integral a) => Parser a
num
  Int
n Int -> Parser () -> Parser Int
forall a b. a -> Parser b -> Parser a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
lo Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
hi)

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

pHeading :: Parser Heading
pHeading :: Parser Heading
pHeading = Parser ()
skipSpaces Parser () -> Parser Heading -> Parser Heading
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> do
  Natural
level       <- [Char] -> Natural
forall i a. Num i => [a] -> i
genericLength ([Char] -> Natural) -> Parser [Char] -> Parser Natural
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser [Char]
munch1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'*') Parser Natural -> Parser [Char] -> Parser Natural
forall a b. Parser a -> Parser b -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser [Char]
" "
  [Char]
headingText <- Parser [Char]
pLine
  Parser [[Char]] -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser [[Char]] -> Parser ()) -> Parser [[Char]] -> Parser ()
forall a b. (a -> b) -> a -> b
$ Parser [Char] -> Parser [[Char]]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser [Char]
pLine Parser [Char] -> ([Char] -> Parser [Char]) -> Parser [Char]
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Char]
line -> Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ([Char] -> Bool
isNotHeading [Char]
line) Parser () -> [Char] -> Parser [Char]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [Char]
line) -- skip body
  Heading -> Parser Heading
forall a. a -> Parser a
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 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') Parser [Char] -> Parser [Char] -> Parser [Char]
forall a b. Parser a -> Parser b -> Parser a
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 (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'*') [Char]
str of
  ([Char]
"", [Char]
_)       -> Bool
True
  ([Char]
_ , Char
' ' : [Char]
_) -> Bool
False
  ([Char], [Char])
_             -> Bool
True