{-# 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  slotThe <soliditsallgood@mailbox.org>
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  slotThe <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.XSelection (getSelection)

import Data.Time (Day (ModifiedJulianDay), NominalDiffTime, UTCTime (utctDay), addUTCTime, defaultTimeLocale, formatTime, fromGregorian, getCurrentTime, iso8601DateFormat, nominalDay, toGregorian)
import System.Directory (getHomeDirectory)
import System.IO (IOMode (AppendMode), hPutStrLn, withFile)
import Text.ParserCombinators.ReadP (ReadP, munch, munch1, readP_to_S, skipSpaces, string, (<++))

{- $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 <- case String
orgFile of
      Char
'/'       : String
_ -> String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
orgFile
      Char
'~' : Char
'/' : String
_ -> IO String
getHomeDirectory IO String -> (String -> String) -> IO String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 String
orgFile)
      String
_             -> IO String
getHomeDirectory IO String -> (String -> String) -> IO String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (Char
'/' Char -> String -> String
forall a. a -> [a] -> [a]
: 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
$cp1Ord :: Eq Date
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
$cp1Ord :: Eq DayOfWeek
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 = ((Note, String) -> Note) -> Maybe (Note, String) -> Maybe Note
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Note, String) -> Note
forall a b. (a, b) -> a
fst (Maybe (Note, String) -> Maybe Note)
-> ([ReadP Note] -> Maybe (Note, String))
-> [ReadP Note]
-> Maybe Note
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Note, String)] -> Maybe (Note, String)
forall a. [a] -> Maybe a
listToMaybe ([(Note, String)] -> Maybe (Note, String))
-> ([ReadP Note] -> [(Note, String)])
-> [ReadP Note]
-> Maybe (Note, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReadP Note -> ReadS Note
forall a. ReadP a -> ReadS a
`readP_to_S` String
inp) (ReadP Note -> [(Note, String)])
-> ([ReadP Note] -> ReadP Note) -> [ReadP Note] -> [(Note, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ReadP Note] -> ReadP Note
forall a. [ReadP a] -> ReadP a
lchoice ([ReadP Note] -> Maybe Note) -> [ReadP Note] -> Maybe Note
forall a b. (a -> b) -> a -> b
$
  [ String -> Time -> Note
Scheduled (String -> Time -> Note) -> ReadP String -> ReadP (Time -> Note)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> ReadP String
getLast String
"+s" ReadP (Time -> Note) -> ReadP Time -> ReadP Note
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Date -> Maybe TimeOfDay -> Time
Time (Date -> Maybe TimeOfDay -> Time)
-> ReadP Date -> ReadP (Maybe TimeOfDay -> Time)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP Date
pDate ReadP (Maybe TimeOfDay -> Time)
-> ReadP (Maybe TimeOfDay) -> ReadP Time
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadP (Maybe TimeOfDay)
pTimeOfDay)
  , String -> Time -> Note
Deadline  (String -> Time -> Note) -> ReadP String -> ReadP (Time -> Note)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> ReadP String
getLast String
"+d" ReadP (Time -> Note) -> ReadP Time -> ReadP Note
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Date -> Maybe TimeOfDay -> Time
Time (Date -> Maybe TimeOfDay -> Time)
-> ReadP Date -> ReadP (Maybe TimeOfDay -> Time)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP Date
pDate ReadP (Maybe TimeOfDay -> Time)
-> ReadP (Maybe TimeOfDay) -> ReadP Time
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadP (Maybe TimeOfDay)
pTimeOfDay)
  , String -> Note
NormalMsg (String -> Note) -> ReadP String -> ReadP Note
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> ReadP String
munch1 (Bool -> Char -> Bool
forall a b. a -> b -> a
const Bool
True)
  ]
 where
  getLast :: String -> ReadP String
  getLast :: String -> ReadP 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) -> ReadP [String] -> ReadP String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP String -> ReadP String -> ReadP [String]
forall a sep. ReadP a -> ReadP sep -> ReadP [a]
endBy1 (String -> ReadP String
go String
"") (String -> ReadP String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
ptn)
   where
    go :: String -> ReadP String
    go :: String -> ReadP String
go String
consumed = do
      String
str  <- (Char -> Bool) -> ReadP 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) -> ReadP String
munch1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ')
      (String -> ReadP String)
-> (String -> ReadP String) -> Bool -> String -> ReadP String
forall a. a -> a -> Bool -> a
bool String -> ReadP String
go String -> ReadP 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 -> ReadP String) -> String -> ReadP 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 :: ReadP (Maybe TimeOfDay)
pTimeOfDay :: ReadP (Maybe TimeOfDay)
pTimeOfDay = [ReadP (Maybe TimeOfDay)] -> ReadP (Maybe TimeOfDay)
forall a. [ReadP a] -> ReadP a
lchoice
  [ TimeOfDay -> Maybe TimeOfDay
forall a. a -> Maybe a
Just (TimeOfDay -> Maybe TimeOfDay)
-> ReadP TimeOfDay -> ReadP (Maybe TimeOfDay)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Int -> TimeOfDay
TimeOfDay (Int -> Int -> TimeOfDay) -> ReadP Int -> ReadP (Int -> TimeOfDay)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP Int
forall a. (Read a, Integral a) => ReadP a
pInt ReadP (Int -> TimeOfDay)
-> ReadP String -> ReadP (Int -> TimeOfDay)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* String -> ReadP String
string String
":" ReadP (Int -> TimeOfDay) -> ReadP Int -> ReadP TimeOfDay
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadP Int
forall a. (Read a, Integral a) => ReadP a
pInt  ) -- HH:MM
  , TimeOfDay -> Maybe TimeOfDay
forall a. a -> Maybe a
Just (TimeOfDay -> Maybe TimeOfDay)
-> ReadP TimeOfDay -> ReadP (Maybe TimeOfDay)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Int -> TimeOfDay
TimeOfDay (Int -> Int -> TimeOfDay) -> ReadP Int -> ReadP (Int -> TimeOfDay)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP Int
forall a. (Read a, Integral a) => ReadP a
pInt               ReadP (Int -> TimeOfDay) -> ReadP Int -> ReadP TimeOfDay
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> ReadP Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0) -- HH
  , Maybe TimeOfDay -> ReadP (Maybe TimeOfDay)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe TimeOfDay
forall a. Maybe a
Nothing
  ]

-- | Parse a 'Date'.
pDate :: ReadP Date
pDate :: ReadP Date
pDate = ReadP ()
skipSpaces ReadP () -> ReadP Date -> ReadP Date
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [ReadP Date] -> ReadP Date
forall a. [ReadP a] -> ReadP a
lchoice
  [ String -> String -> Date -> ReadP Date
forall a. String -> String -> a -> ReadP a
pString String
"tod" String
"ay"    Date
Today
  , String -> String -> Date -> ReadP Date
forall a. String -> String -> a -> ReadP a
pString String
"tom" String
"orrow" Date
Tomorrow
  , DayOfWeek -> Date
Next     (DayOfWeek -> Date) -> ReadP DayOfWeek -> ReadP Date
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP DayOfWeek
pNext
  , (Int, Maybe Int, Maybe Integer) -> Date
Date     ((Int, Maybe Int, Maybe Integer) -> Date)
-> ReadP (Int, Maybe Int, Maybe Integer) -> ReadP Date
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP (Int, Maybe Int, Maybe Integer)
pDate1 ReadP (Int, Maybe Int, Maybe Integer)
-> ReadP (Int, Maybe Int, Maybe Integer)
-> ReadP (Int, Maybe Int, Maybe Integer)
forall a. ReadP a -> ReadP a -> ReadP a
<++ ReadP (Int, Maybe Int, Maybe Integer)
pDate2 ReadP (Int, Maybe Int, Maybe Integer)
-> ReadP (Int, Maybe Int, Maybe Integer)
-> ReadP (Int, Maybe Int, Maybe Integer)
forall a. ReadP a -> ReadP a -> ReadP a
<++ ReadP (Int, Maybe Int, Maybe Integer)
pDate3
  ] ReadP Date -> ReadP () -> ReadP Date
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP ()
skipSpaces  -- cleanup
 where
  ReadP DayOfWeek
pNext :: ReadP DayOfWeek = [ReadP DayOfWeek] -> ReadP DayOfWeek
forall a. [ReadP a] -> ReadP a
lchoice
    [ String -> String -> DayOfWeek -> ReadP DayOfWeek
forall a. String -> String -> a -> ReadP a
pString String
"m"  String
"onday"    DayOfWeek
Monday   , String -> String -> DayOfWeek -> ReadP DayOfWeek
forall a. String -> String -> a -> ReadP a
pString String
"tu" String
"esday"  DayOfWeek
Tuesday
    , String -> String -> DayOfWeek -> ReadP DayOfWeek
forall a. String -> String -> a -> ReadP a
pString String
"w"  String
"ednesday" DayOfWeek
Wednesday, String -> String -> DayOfWeek -> ReadP DayOfWeek
forall a. String -> String -> a -> ReadP a
pString String
"th" String
"ursday" DayOfWeek
Thursday
    , String -> String -> DayOfWeek -> ReadP DayOfWeek
forall a. String -> String -> a -> ReadP a
pString String
"f"  String
"riday"    DayOfWeek
Friday   , String -> String -> DayOfWeek -> ReadP DayOfWeek
forall a. String -> String -> a -> ReadP a
pString String
"sa" String
"turday" DayOfWeek
Saturday
    , String -> String -> DayOfWeek -> ReadP DayOfWeek
forall a. String -> String -> a -> ReadP a
pString String
"su" String
"nday"     DayOfWeek
Sunday
    ]

  -- XXX: This is really horrible, but I can't see a way to not have
  -- exponential blowup with ReadP otherwise.
  pDate1, pDate2, pDate3 :: ReadP (Int, Maybe Int, Maybe Integer)
  pDate1 :: ReadP (Int, Maybe Int, Maybe Integer)
pDate1 = (ReadP Int -> ReadP (Maybe Int))
-> (ReadP Integer -> ReadP (Maybe Integer))
-> ReadP (Int, Maybe Int, Maybe Integer)
forall (f :: * -> *).
(ReadP Int -> ReadP (f Int))
-> (ReadP Integer -> ReadP (f Integer))
-> ReadP (Int, f Int, f Integer)
pDate' ((Int -> Maybe Int) -> ReadP Int -> ReadP (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Maybe Int
forall a. a -> Maybe a
Just)            ((Integer -> Maybe Integer)
-> ReadP Integer -> ReadP (Maybe Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> Maybe Integer
forall a. a -> Maybe a
Just)
  pDate2 :: ReadP (Int, Maybe Int, Maybe Integer)
pDate2 = (ReadP Int -> ReadP (Maybe Int))
-> (ReadP Integer -> ReadP (Maybe Integer))
-> ReadP (Int, Maybe Int, Maybe Integer)
forall (f :: * -> *).
(ReadP Int -> ReadP (f Int))
-> (ReadP Integer -> ReadP (f Integer))
-> ReadP (Int, f Int, f Integer)
pDate' ((Int -> Maybe Int) -> ReadP Int -> ReadP (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Maybe Int
forall a. a -> Maybe a
Just)            (ReadP (Maybe Integer) -> ReadP Integer -> ReadP (Maybe Integer)
forall a b. a -> b -> a
const (Maybe Integer -> ReadP (Maybe Integer)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Integer
forall a. Maybe a
Nothing))
  pDate3 :: ReadP (Int, Maybe Int, Maybe Integer)
pDate3 = (ReadP Int -> ReadP (Maybe Int))
-> (ReadP Integer -> ReadP (Maybe Integer))
-> ReadP (Int, Maybe Int, Maybe Integer)
forall (f :: * -> *).
(ReadP Int -> ReadP (f Int))
-> (ReadP Integer -> ReadP (f Integer))
-> ReadP (Int, f Int, f Integer)
pDate' (ReadP (Maybe Int) -> ReadP Int -> ReadP (Maybe Int)
forall a b. a -> b -> a
const (Maybe Int -> ReadP (Maybe Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
forall a. Maybe a
Nothing)) (ReadP (Maybe Integer) -> ReadP Integer -> ReadP (Maybe Integer)
forall a b. a -> b -> a
const (Maybe Integer -> ReadP (Maybe Integer)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Integer
forall a. Maybe a
Nothing))
  pDate'
    :: (ReadP Int     -> ReadP (f Int    ))
    -> (ReadP Integer -> ReadP (f Integer))
    -> ReadP (Int, f Int, f Integer)
  pDate' :: (ReadP Int -> ReadP (f Int))
-> (ReadP Integer -> ReadP (f Integer))
-> ReadP (Int, f Int, f Integer)
pDate' ReadP Int -> ReadP (f Int)
p ReadP Integer -> ReadP (f Integer)
p' =
    (,,) (Int -> f Int -> f Integer -> (Int, f Int, f Integer))
-> ReadP Int
-> ReadP (f Int -> f Integer -> (Int, f Int, f Integer))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP Int
forall a. (Read a, Integral a) => ReadP a
pInt
         ReadP (f Int -> f Integer -> (Int, f Int, f Integer))
-> ReadP (f Int) -> ReadP (f Integer -> (Int, f Int, f Integer))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadP Int -> ReadP (f Int)
p (ReadP ()
skipSpaces ReadP () -> ReadP Int -> ReadP Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [ReadP Int] -> ReadP Int
forall a. [ReadP a] -> ReadP a
lchoice
               [ String -> String -> Int -> ReadP Int
forall a. String -> String -> a -> ReadP a
pString String
"ja"  String
"nuary"    Int
1 , String -> String -> Int -> ReadP Int
forall a. String -> String -> a -> ReadP a
pString String
"f"   String
"ebruary" Int
2
               , String -> String -> Int -> ReadP Int
forall a. String -> String -> a -> ReadP a
pString String
"mar" String
"ch"       Int
3 , String -> String -> Int -> ReadP Int
forall a. String -> String -> a -> ReadP a
pString String
"ap"  String
"ril"     Int
4
               , String -> String -> Int -> ReadP Int
forall a. String -> String -> a -> ReadP a
pString String
"may" String
""         Int
5 , String -> String -> Int -> ReadP Int
forall a. String -> String -> a -> ReadP a
pString String
"jun" String
"e"       Int
6
               , String -> String -> Int -> ReadP Int
forall a. String -> String -> a -> ReadP a
pString String
"jul" String
"y"        Int
7 , String -> String -> Int -> ReadP Int
forall a. String -> String -> a -> ReadP a
pString String
"au"  String
"gust"    Int
8
               , String -> String -> Int -> ReadP Int
forall a. String -> String -> a -> ReadP a
pString String
"s"   String
"eptember" Int
9 , String -> String -> Int -> ReadP Int
forall a. String -> String -> a -> ReadP a
pString String
"o"   String
"ctober"  Int
10
               , String -> String -> Int -> ReadP Int
forall a. String -> String -> a -> ReadP a
pString String
"n"   String
"ovember"  Int
11, String -> String -> Int -> ReadP Int
forall a. String -> String -> a -> ReadP a
pString String
"d"   String
"ecember" Int
12
               ])
         ReadP (f Integer -> (Int, f Int, f Integer))
-> ReadP (f Integer) -> ReadP (Int, f Int, f Integer)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadP Integer -> ReadP (f Integer)
p' (ReadP ()
skipSpaces ReadP () -> ReadP Integer -> ReadP Integer
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ReadP Integer
forall a. (Read a, Integral a) => ReadP a
pInt ReadP Integer -> (Integer -> ReadP Integer) -> ReadP Integer
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Integer
i -> Bool -> ReadP ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
25) ReadP () -> Integer -> ReadP Integer
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Integer
i)

-- | Parse a @start@ and see whether the rest of the word (separated by
-- spaces) fits the @leftover@.
pString :: String -> String -> a -> ReadP a
pString :: String -> String -> a -> ReadP a
pString String
start String
leftover a
ret = do
  ReadP String -> ReadP ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReadP String -> ReadP ()) -> ReadP String -> ReadP ()
forall a b. (a -> b) -> a -> b
$ String -> ReadP String
string String
start
  String
l <- (Char -> Bool) -> ReadP String
munch (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ')
  Bool -> ReadP ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (String
l String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
leftover)
  a -> ReadP a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
ret

-- | Parse a number.
pInt :: (Read a, Integral a) => ReadP a
pInt :: ReadP a
pInt = String -> a
forall a. Read a => String -> a
read (String -> a) -> ReadP String -> ReadP a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> ReadP String
munch1 Char -> Bool
isDigit

-- | Like 'choice', but with '(<++)' instead of '(+++)', stopping
-- parsing when the left-most parser succeeds.
lchoice :: [ReadP a] -> ReadP a
lchoice :: [ReadP a] -> ReadP a
lchoice = (ReadP a -> ReadP a -> ReadP a) -> ReadP a -> [ReadP a] -> ReadP a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ReadP a -> ReadP a -> ReadP a
forall a. ReadP a -> ReadP a -> ReadP a
(<++) ReadP a
forall (f :: * -> *) a. Alternative f => f a
empty

-- | Like 'Text.ParserCombinators.ReadP.endBy1', but only return the
-- parse where @parser@ had the highest number of applications.
endBy1 :: ReadP a -> ReadP sep -> ReadP [a]
endBy1 :: ReadP a -> ReadP sep -> ReadP [a]
endBy1 ReadP a
parser ReadP sep
sep = ReadP a -> ReadP [a]
forall a. ReadP a -> ReadP [a]
many1 (ReadP a
parser ReadP a -> ReadP sep -> ReadP a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP sep
sep)
 where
  -- | Like 'Text.ParserCombinators.ReadP.many1', but use '(<++)'
  -- instead of '(+++)'.
  many1 :: ReadP a -> ReadP [a]
  many1 :: ReadP a -> ReadP [a]
many1 ReadP a
p = (:) (a -> [a] -> [a]) -> ReadP a -> ReadP ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP a
p ReadP ([a] -> [a]) -> ReadP [a] -> ReadP [a]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ReadP a -> ReadP [a]
forall a. ReadP a -> ReadP [a]
many1 ReadP a
p ReadP [a] -> ReadP [a] -> ReadP [a]
forall a. ReadP a -> ReadP a -> ReadP a
<++ [a] -> ReadP [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])