{-# LANGUAGE CPP                 #-}
{-# LANGUAGE InstanceSigs        #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE StrictData          #-}
{-# LANGUAGE ScopedTypeVariables #-}
--------------------------------------------------------------------
-- |
-- 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, or use
-- the system's clipboard (really: the primary selection) as the
-- contents of the note.
--
--------------------------------------------------------------------
module XMonad.Prompt.OrgMode (
    -- * Usage
    -- $usage

    -- * Prompts
    orgPrompt,              -- :: XPConfig -> String -> FilePath -> X ()
    orgPromptPrimary,       -- :: XPConfig -> String -> FilePath -> X ()

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

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

) where

import XMonad.Prelude

import XMonad (X, io)
import XMonad.Prompt (XPConfig, XPrompt (showXPrompt), mkXPrompt)
import XMonad.Util.Parser
import XMonad.Util.XSelection (getSelection)

import Data.Time (Day (ModifiedJulianDay), NominalDiffTime, UTCTime (utctDay), addUTCTime, defaultTimeLocale, formatTime, fromGregorian, getCurrentTime, iso8601DateFormat, nominalDay, toGregorian)
import System.IO (IOMode (AppendMode), hPutStrLn, 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@ format.  The minutes may be
omitted, in which case we assume a full hour is specified.

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 +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'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.

-}

{- 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 -> String
todoHeader :: String    -- ^ Will display like @* todoHeader @
  , OrgMode -> String
orgFile    :: FilePath
  }

-- | 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 -> String
showXPrompt OrgMode{ String
todoHeader :: String
todoHeader :: OrgMode -> String
todoHeader, String
orgFile :: String
orgFile :: OrgMode -> String
orgFile, ClipboardSupport
clpSupport :: ClipboardSupport
clpSupport :: OrgMode -> ClipboardSupport
clpSupport } =
    [String] -> String
forall a. Monoid a => [a] -> a
mconcat [String
"Add ", String
todoHeader, String
clp, String
" to ", String
orgFile, String
": "]
   where
    String
clp :: String = case ClipboardSupport
clpSupport of
      ClipboardSupport
NoClpSupport     -> String
""
      ClipboardSupport
PrimarySelection -> String
" + 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 -> String -> String -> X ()
orgPrompt XPConfig
xpc = XPConfig -> OrgMode -> X ()
mkOrgPrompt XPConfig
xpc (OrgMode -> X ())
-> (String -> String -> OrgMode) -> String -> String -> X ()
forall a b c d. (a -> b) -> (c -> d -> a) -> c -> d -> b
.: ClipboardSupport -> String -> String -> OrgMode
OrgMode 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 -> String -> String -> X ()
orgPromptPrimary XPConfig
xpc = XPConfig -> OrgMode -> X ()
mkOrgPrompt XPConfig
xpc (OrgMode -> X ())
-> (String -> String -> OrgMode) -> String -> String -> X ()
forall a b c d. (a -> b) -> (c -> d -> a) -> c -> d -> b
.: ClipboardSupport -> String -> String -> OrgMode
OrgMode ClipboardSupport
PrimarySelection

-- | Create the actual prompt.
mkOrgPrompt :: XPConfig -> OrgMode -> X ()
mkOrgPrompt :: XPConfig -> OrgMode -> X ()
mkOrgPrompt XPConfig
xpc oc :: OrgMode
oc@OrgMode{ String
todoHeader :: String
todoHeader :: OrgMode -> String
todoHeader, String
orgFile :: String
orgFile :: OrgMode -> String
orgFile, ClipboardSupport
clpSupport :: ClipboardSupport
clpSupport :: OrgMode -> ClipboardSupport
clpSupport } =
  OrgMode -> XPConfig -> ComplFunction -> (String -> X ()) -> X ()
forall p.
XPrompt p =>
p -> XPConfig -> ComplFunction -> (String -> X ()) -> X ()
mkXPrompt OrgMode
oc XPConfig
xpc (IO [String] -> ComplFunction
forall a b. a -> b -> a
const ([String] -> IO [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])) String -> 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 :: String -> X ()
appendNote String
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 (f :: * -> *) a. Applicative f => a -> f a
pure (Clp -> IO Clp) -> Clp -> IO Clp
forall a b. (a -> b) -> a -> b
$ String -> Clp
Body String
""
      ClipboardSupport
PrimarySelection -> do
        String
sel <- IO String
forall (m :: * -> *). MonadIO m => m String
getSelection
        Clp -> IO Clp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Clp -> IO Clp) -> Clp -> IO Clp
forall a b. (a -> b) -> a -> b
$ if   (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
sel) [String
"http://", String
"https://"]
               then String -> Clp
Header String
sel
               else String -> Clp
Body   (String -> Clp) -> String -> Clp
forall a b. (a -> b) -> a -> b
$ String
"\n " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
sel

    -- Expand path if applicable
    String
fp <- String -> IO String
forall (m :: * -> *). MonadIO m => String -> m String
mkAbsolutePath String
orgFile

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

------------------------------------------------------------------------
-- 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 TimeOfDay
tod  :: Maybe TimeOfDay
  }
  deriving (Time -> Time -> Bool
(Time -> Time -> Bool) -> (Time -> Time -> Bool) -> Eq Time
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 -> String -> String
[Time] -> String -> String
Time -> String
(Int -> Time -> String -> String)
-> (Time -> String) -> ([Time] -> String -> String) -> Show Time
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Time] -> String -> String
$cshowList :: [Time] -> String -> String
show :: Time -> String
$cshow :: Time -> String
showsPrec :: Int -> Time -> String -> String
$cshowsPrec :: Int -> Time -> String -> String
Show)

-- | The time in HH:MM.
data TimeOfDay = TimeOfDay Int Int
  deriving (TimeOfDay -> TimeOfDay -> Bool
(TimeOfDay -> TimeOfDay -> Bool)
-> (TimeOfDay -> TimeOfDay -> Bool) -> Eq TimeOfDay
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 -> String
show (TimeOfDay Int
h Int
m) = Int -> String
pad Int
h String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
pad Int
m
   where
    pad :: Int -> String
    pad :: Int -> String
pad Int
n = (if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
9 then String
"0" else String
"") String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
n

-- | 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
/= :: Date -> Date -> Bool
$c/= :: Date -> Date -> Bool
== :: Date -> Date -> Bool
$c== :: 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
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 -> String -> String
[Date] -> String -> String
Date -> String
(Int -> Date -> String -> String)
-> (Date -> String) -> ([Date] -> String -> String) -> Show Date
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Date] -> String -> String
$cshowList :: [Date] -> String -> String
show :: Date -> String
$cshow :: Date -> String
showsPrec :: Int -> Date -> String -> String
$cshowsPrec :: Int -> Date -> String -> String
Show)

toOrgFmt :: Maybe TimeOfDay -> Day -> String
toOrgFmt :: Maybe TimeOfDay -> Day -> String
toOrgFmt Maybe TimeOfDay
tod Day
day =
  [String] -> String
forall a. Monoid a => [a] -> a
mconcat [String
"<", String
isoDay, String
" ", Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
3 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ DayOfWeek -> String
forall a. Show a => a -> String
show (Day -> DayOfWeek
dayOfWeek Day
day), String
time, String
">"]
 where
  String
time   :: String = String -> (TimeOfDay -> String) -> Maybe TimeOfDay -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ((Char
' ' Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> (TimeOfDay -> String) -> TimeOfDay -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeOfDay -> String
forall a. Show a => a -> String
show) Maybe TimeOfDay
tod
  String
isoDay :: String = TimeLocale -> String -> Day -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale (Maybe String -> String
iso8601DateFormat Maybe String
forall a. Maybe a
Nothing) Day
day

-- | Pretty print a 'Date' and an optional time to reflect the actual
-- date.
ppDate :: Time -> IO String
ppDate :: Time -> IO String
ppDate Time{ Date
date :: Date
date :: Time -> Date
date, Maybe TimeOfDay
tod :: Maybe TimeOfDay
tod :: Time -> Maybe TimeOfDay
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)

  String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String) -> (Day -> String) -> Day -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe TimeOfDay -> Day -> String
toOrgFmt Maybe TimeOfDay
tod (Day -> IO String) -> Day -> IO String
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
/= :: DayOfWeek -> DayOfWeek -> Bool
$c/= :: DayOfWeek -> DayOfWeek -> Bool
== :: DayOfWeek -> DayOfWeek -> Bool
$c== :: 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
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 -> String -> String
[DayOfWeek] -> String -> String
DayOfWeek -> String
(Int -> DayOfWeek -> String -> String)
-> (DayOfWeek -> String)
-> ([DayOfWeek] -> String -> String)
-> Show DayOfWeek
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [DayOfWeek] -> String -> String
$cshowList :: [DayOfWeek] -> String -> String
show :: DayOfWeek -> String
$cshow :: DayOfWeek -> String
showsPrec :: Int -> DayOfWeek -> String -> String
$cshowsPrec :: Int -> DayOfWeek -> String -> String
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
  | Deadline  String Time
  | NormalMsg String
  deriving (Note -> Note -> Bool
(Note -> Note -> Bool) -> (Note -> Note -> Bool) -> Eq Note
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 -> String -> String
[Note] -> String -> String
Note -> String
(Int -> Note -> String -> String)
-> (Note -> String) -> ([Note] -> String -> String) -> Show Note
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Note] -> String -> String
$cshowList :: [Note] -> String -> String
show :: Note -> String
$cshow :: Note -> String
showsPrec :: Int -> Note -> String -> String
$cshowsPrec :: Int -> Note -> String -> String
Show)

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

------------------------------------------------------------------------
-- Parsing

-- | Parse the given string into a 'Note'.
pInput :: String -> Maybe Note
pInput :: String -> Maybe Note
pInput String
inp = (Parser Note -> String -> Maybe Note
forall a. Parser a -> String -> Maybe a
`runParser` String
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
$
  [ String -> Time -> Note
Scheduled (String -> Time -> Note) -> Parser String -> Parser (Time -> Note)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Parser String
getLast String
"+s" Parser (Time -> Note) -> Parser Time -> Parser Note
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Date -> Maybe TimeOfDay -> Time
Time (Date -> Maybe TimeOfDay -> Time)
-> Parser Date -> Parser (Maybe TimeOfDay -> Time)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Date
pDate Parser (Maybe TimeOfDay -> Time)
-> Parser (Maybe TimeOfDay) -> Parser Time
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe TimeOfDay)
pTimeOfDay)
  , String -> Time -> Note
Deadline  (String -> Time -> Note) -> Parser String -> Parser (Time -> Note)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Parser String
getLast String
"+d" Parser (Time -> Note) -> Parser Time -> Parser Note
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Date -> Maybe TimeOfDay -> Time
Time (Date -> Maybe TimeOfDay -> Time)
-> Parser Date -> Parser (Maybe TimeOfDay -> Time)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Date
pDate Parser (Maybe TimeOfDay -> Time)
-> Parser (Maybe TimeOfDay) -> Parser Time
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe TimeOfDay)
pTimeOfDay)
  , String -> Note
NormalMsg (String -> Note) -> Parser String -> Parser Note
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser String
munch1 (Bool -> Char -> Bool
forall a b. a -> b -> a
const Bool
True)
  ]
 where
  getLast :: String -> Parser String
  getLast :: String -> Parser String
getLast String
ptn =  String -> String
forall a. [a] -> [a]
reverse
              (String -> String) -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')    -- trim whitespace at the end
              (String -> String) -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  Int -> String -> String
forall a. Int -> [a] -> [a]
drop (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
ptn)     -- drop only the last pattern
              (String -> String) -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  String -> String
forall a. [a] -> [a]
reverse
              (String -> String) -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
             ([String] -> String) -> Parser [String] -> Parser String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String -> Parser String -> Parser [String]
forall a sep. Parser a -> Parser sep -> Parser [a]
endBy1 (String -> Parser String
go String
"") (String -> Parser String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
ptn)
   where
    go :: String -> Parser String
    go :: String -> Parser String
go String
consumed = do
      String
str  <- (Char -> Bool) -> Parser String
munch  (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= String -> Char
forall a. [a] -> a
head String
ptn)
      String
word <- (Char -> Bool) -> Parser String
munch1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ')
      (String -> Parser String)
-> (String -> Parser String) -> Bool -> String -> Parser String
forall a. a -> a -> Bool -> a
bool String -> Parser String
go String -> Parser String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
word String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
ptn) (String -> Parser String) -> String -> Parser String
forall a b. (a -> b) -> a -> b
$ String
consumed String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
str String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
word

-- | Try to parse a 'Time'.
pTimeOfDay :: Parser (Maybe TimeOfDay)
pTimeOfDay :: Parser (Maybe TimeOfDay)
pTimeOfDay = [Parser (Maybe TimeOfDay)] -> Parser (Maybe TimeOfDay)
forall a. [Parser a] -> Parser a
choice
  [ TimeOfDay -> Maybe TimeOfDay
forall a. a -> Maybe a
Just (TimeOfDay -> Maybe TimeOfDay)
-> Parser TimeOfDay -> Parser (Maybe TimeOfDay)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Int -> TimeOfDay
TimeOfDay (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 String -> Parser (Int -> TimeOfDay)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* String -> Parser String
string String
":" Parser (Int -> TimeOfDay) -> Parser Int -> Parser TimeOfDay
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Int
pMinute) -- HH:MM
  , TimeOfDay -> Maybe TimeOfDay
forall a. a -> Maybe a
Just (TimeOfDay -> Maybe TimeOfDay)
-> Parser TimeOfDay -> Parser (Maybe TimeOfDay)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Int -> TimeOfDay
TimeOfDay (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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Parser Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0 ) -- HH
  , Maybe TimeOfDay -> Parser (Maybe TimeOfDay)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe TimeOfDay
forall a. Maybe a
Nothing
  ]
 where
  Parser Int
pMinute :: Parser Int = Int -> Int -> Parser Int
pNumBetween Int
1 Int
60
  Parser Int
pHour   :: Parser Int = Int -> Int -> Parser Int
pNumBetween Int
1 Int
24

-- | Parse a 'Date'.
pDate :: Parser Date
pDate :: Parser Date
pDate = Parser ()
skipSpaces Parser () -> Parser Date -> Parser Date
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Parser Date] -> Parser Date
forall a. [Parser a] -> Parser a
choice
  [ String -> String -> Date -> Parser Date
forall a. String -> String -> a -> Parser a
pPrefix String
"tod" String
"ay"    Date
Today
  , String -> String -> Date -> Parser Date
forall a. String -> String -> a -> Parser a
pPrefix String
"tom" String
"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'
  ] Parser Date -> Parser () -> Parser Date
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpaces  -- cleanup
 where
  Parser DayOfWeek
pNext :: Parser DayOfWeek = [Parser DayOfWeek] -> Parser DayOfWeek
forall a. [Parser a] -> Parser a
choice
    [ String -> String -> DayOfWeek -> Parser DayOfWeek
forall a. String -> String -> a -> Parser a
pPrefix String
"m"  String
"onday"    DayOfWeek
Monday   , String -> String -> DayOfWeek -> Parser DayOfWeek
forall a. String -> String -> a -> Parser a
pPrefix String
"tu" String
"esday"  DayOfWeek
Tuesday
    , String -> String -> DayOfWeek -> Parser DayOfWeek
forall a. String -> String -> a -> Parser a
pPrefix String
"w"  String
"ednesday" DayOfWeek
Wednesday, String -> String -> DayOfWeek -> Parser DayOfWeek
forall a. String -> String -> a -> Parser a
pPrefix String
"th" String
"ursday" DayOfWeek
Thursday
    , String -> String -> DayOfWeek -> Parser DayOfWeek
forall a. String -> String -> a -> Parser a
pPrefix String
"f"  String
"riday"    DayOfWeek
Friday   , String -> String -> DayOfWeek -> Parser DayOfWeek
forall a. String -> String -> a -> Parser a
pPrefix String
"sa" String
"turday" DayOfWeek
Saturday
    , String -> String -> DayOfWeek -> Parser DayOfWeek
forall a. String -> String -> a -> Parser a
pPrefix String
"su" String
"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 (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               -- day
         Parser
  (Maybe Int -> Maybe Integer -> (Int, Maybe Int, Maybe Integer))
-> Parser (Maybe Int)
-> Parser (Maybe Integer -> (Int, Maybe Int, Maybe Integer))
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 (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Parser Int] -> Parser Int
forall a. [Parser a] -> Parser a
choice
               [ String -> String -> Int -> Parser Int
forall a. String -> String -> a -> Parser a
pPrefix String
"ja"  String
"nuary"    Int
1 , String -> String -> Int -> Parser Int
forall a. String -> String -> a -> Parser a
pPrefix String
"f"   String
"ebruary" Int
2
               , String -> String -> Int -> Parser Int
forall a. String -> String -> a -> Parser a
pPrefix String
"mar" String
"ch"       Int
3 , String -> String -> Int -> Parser Int
forall a. String -> String -> a -> Parser a
pPrefix String
"ap"  String
"ril"     Int
4
               , String -> String -> Int -> Parser Int
forall a. String -> String -> a -> Parser a
pPrefix String
"may" String
""         Int
5 , String -> String -> Int -> Parser Int
forall a. String -> String -> a -> Parser a
pPrefix String
"jun" String
"e"       Int
6
               , String -> String -> Int -> Parser Int
forall a. String -> String -> a -> Parser a
pPrefix String
"jul" String
"y"        Int
7 , String -> String -> Int -> Parser Int
forall a. String -> String -> a -> Parser a
pPrefix String
"au"  String
"gust"    Int
8
               , String -> String -> Int -> Parser Int
forall a. String -> String -> a -> Parser a
pPrefix String
"s"   String
"eptember" Int
9 , String -> String -> Int -> Parser Int
forall a. String -> String -> a -> Parser a
pPrefix String
"o"   String
"ctober"  Int
10
               , String -> String -> Int -> Parser Int
forall a. String -> String -> a -> Parser a
pPrefix String
"n"   String
"ovember"  Int
11, String -> String -> Int -> Parser Int
forall a. String -> String -> a -> Parser a
pPrefix String
"d"   String
"ecember" Int
12
               , Parser Int
numWithoutColon
               ])
         Parser (Maybe Integer -> (Int, Maybe Int, Maybe Integer))
-> Parser (Maybe Integer) -> Parser (Int, Maybe Int, Maybe Integer)
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 (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 (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. String -> String -> a -> Parser a
pPrefix String
start String
leftover a
ret = do
    Parser String -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser String -> Parser ()) -> Parser String -> Parser ()
forall a b. (a -> b) -> a -> b
$ String -> Parser String
string String
start
    String
l <- (Char -> Bool) -> Parser String
munch (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ')
    Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (String
l String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
leftover)
    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 (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)