{-# LANGUAGE CPP #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
module XMonad.Prompt.OrgMode (
orgPrompt,
orgPromptPrimary,
ClipboardSupport (..),
OrgMode,
#ifdef TESTING
pInput,
Note (..),
Priority (..),
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)
data OrgMode = OrgMode
{ OrgMode -> ClipboardSupport
clpSupport :: ClipboardSupport
, :: String
, OrgMode -> String
orgFile :: FilePath
}
data ClipboardSupport
= PrimarySelection
| NoClpSupport
data Clp
= String
| Body String
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 } =
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"
orgPrompt
:: XPConfig
-> String
-> FilePath
-> X ()
orgPrompt :: XPConfig -> String -> String -> X ()
orgPrompt XPConfig
xpc = XPConfig -> OrgMode -> X ()
mkOrgPrompt XPConfig
xpc forall a b c d. (a -> b) -> (c -> d -> a) -> c -> d -> b
.: ClipboardSupport -> String -> String -> OrgMode
OrgMode ClipboardSupport
NoClpSupport
orgPromptPrimary :: XPConfig -> String -> FilePath -> X ()
orgPromptPrimary :: XPConfig -> String -> String -> X ()
orgPromptPrimary XPConfig
xpc = XPConfig -> OrgMode -> X ()
mkOrgPrompt XPConfig
xpc forall a b c d. (a -> b) -> (c -> d -> a) -> c -> d -> b
.: ClipboardSupport -> String -> String -> OrgMode
OrgMode ClipboardSupport
PrimarySelection
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 } =
forall p.
XPrompt p =>
p -> XPConfig -> ComplFunction -> (String -> X ()) -> X ()
mkXPrompt OrgMode
oc XPConfig
xpc (forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure [])) String -> X ()
appendNote
where
appendNote :: String -> X ()
appendNote :: String -> X ()
appendNote String
input = forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ do
Clp
clpStr <- case ClipboardSupport
clpSupport of
ClipboardSupport
NoClpSupport -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> Clp
Body String
""
ClipboardSupport
PrimarySelection -> do
String
sel <- forall (m :: * -> *). MonadIO m => m String
getSelection
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
sel) [String
"http://", String
"https://"]
then String -> Clp
Header String
sel
else String -> Clp
Body forall a b. (a -> b) -> a -> b
$ String
"\n " forall a. Semigroup a => a -> a -> a
<> String
sel
String
fp <- forall (m :: * -> *). MonadIO m => String -> m String
mkAbsolutePath String
orgFile
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
fp IOMode
AppendMode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip Handle -> String -> IO ()
hPutStrLn
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"") (Clp -> String -> Note -> IO String
ppNote Clp
clpStr String
todoHeader) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Note
pInput
forall a b. (a -> b) -> a -> b
$ String
input
data Time = Time
{ Time -> Date
date :: Date
, Time -> Maybe TimeOfDay
tod :: Maybe TimeOfDay
}
deriving (Time -> Time -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Time -> Time -> Bool
$c/= :: Time -> Time -> Bool
== :: Time -> Time -> Bool
$c== :: Time -> Time -> Bool
Eq, Int -> Time -> String -> String
[Time] -> String -> String
Time -> String
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)
data TimeOfDay = TimeOfDay Int Int
deriving (TimeOfDay -> TimeOfDay -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TimeOfDay -> TimeOfDay -> Bool
$c/= :: TimeOfDay -> TimeOfDay -> Bool
== :: TimeOfDay -> TimeOfDay -> Bool
$c== :: TimeOfDay -> TimeOfDay -> Bool
Eq)
instance Show TimeOfDay where
show :: TimeOfDay -> String
show :: TimeOfDay -> String
show (TimeOfDay Int
h Int
m) = Int -> String
pad Int
h forall a. Semigroup a => a -> a -> a
<> 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 forall a. Ord a => a -> a -> Bool
<= Int
9 then String
"0" else String
"") forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
n
data Date
= Today
| Tomorrow
| Next DayOfWeek
| Date (Int, Maybe Int, Maybe Integer)
deriving (Date -> Date -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Date -> Date -> Bool
$c/= :: Date -> Date -> Bool
== :: Date -> Date -> Bool
$c== :: Date -> Date -> Bool
Eq, Eq Date
Date -> Date -> Bool
Date -> Date -> Ordering
Date -> Date -> Date
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Date -> Date -> Date
$cmin :: Date -> Date -> Date
max :: Date -> Date -> Date
$cmax :: Date -> Date -> Date
>= :: Date -> Date -> Bool
$c>= :: Date -> Date -> Bool
> :: Date -> Date -> Bool
$c> :: Date -> Date -> Bool
<= :: Date -> Date -> Bool
$c<= :: Date -> Date -> Bool
< :: Date -> Date -> Bool
$c< :: Date -> Date -> Bool
compare :: Date -> Date -> Ordering
$ccompare :: Date -> Date -> Ordering
Ord, Int -> Date -> String -> String
[Date] -> String -> String
Date -> String
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 =
forall a. Monoid a => [a] -> a
mconcat [String
"<", String
isoDay, String
" ", forall a. Int -> [a] -> [a]
take Int
3 forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (Day -> DayOfWeek
dayOfWeek Day
day), String
time, String
">"]
where
String
time :: String = forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ((Char
' ' forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) Maybe TimeOfDay
tod
String
isoDay :: String = forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale (Maybe String -> String
iso8601DateFormat forall a. Maybe a
Nothing) Day
day
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)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe TimeOfDay -> Day -> String
toOrgFmt Maybe TimeOfDay
tod forall a b. (a -> b) -> a -> b
$ case Date
date of
Date
Today -> Day
curDay
Date
Tomorrow -> UTCTime -> Day
utctDay forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> UTCTime -> UTCTime
addDays NominalDiffTime
1 UTCTime
curTime
Next DayOfWeek
wday -> UTCTime -> Day
utctDay forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> UTCTime -> UTCTime
addDays (DayOfWeek -> NominalDiffTime
diffToDay DayOfWeek
wday) UTCTime
curTime
Date (Int
d, Maybe Int
mbM, Maybe Integer
mbY) -> Integer -> Int -> Int -> Day
fromGregorian (forall a. a -> Maybe a -> a
fromMaybe Integer
y Maybe Integer
mbY) (forall a. a -> Maybe a -> a
fromMaybe Int
m Maybe Int
mbM) Int
d
where
NominalDiffTime -> UTCTime -> UTCTime
addDays :: NominalDiffTime -> UTCTime -> UTCTime
= NominalDiffTime -> UTCTime -> UTCTime
addUTCTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
* NominalDiffTime
nominalDay)
diffBetween :: DayOfWeek -> DayOfWeek -> NominalDiffTime
diffBetween :: DayOfWeek -> DayOfWeek -> NominalDiffTime
diffBetween DayOfWeek
d DayOfWeek
cur
| DayOfWeek
d forall a. Eq a => a -> a -> Bool
== DayOfWeek
cur = NominalDiffTime
7
| Bool
otherwise = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a
abs forall a b. (a -> b) -> a -> b
$ (forall a. Enum a => a -> Int
fromEnum DayOfWeek
d forall a. Num a => a -> a -> a
- forall a. Enum a => a -> Int
fromEnum DayOfWeek
cur) forall a. Integral a => a -> a -> a
`mod` Int
7
dayOfWeek :: Day -> DayOfWeek
dayOfWeek :: Day -> DayOfWeek
dayOfWeek (ModifiedJulianDay Integer
d) = forall a. Enum a => Int -> a
toEnum forall a b. (a -> b) -> a -> b
$ forall a. Num a => Integer -> a
fromInteger forall a b. (a -> b) -> a -> b
$ Integer
d forall a. Num a => a -> a -> a
+ Integer
3
data DayOfWeek
= Monday | Tuesday | Wednesday | Thursday | Friday | Saturday | Sunday
deriving (DayOfWeek -> DayOfWeek -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DayOfWeek -> DayOfWeek -> Bool
$c/= :: DayOfWeek -> DayOfWeek -> Bool
== :: DayOfWeek -> DayOfWeek -> Bool
$c== :: DayOfWeek -> DayOfWeek -> Bool
Eq, Eq DayOfWeek
DayOfWeek -> DayOfWeek -> Bool
DayOfWeek -> DayOfWeek -> Ordering
DayOfWeek -> DayOfWeek -> DayOfWeek
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DayOfWeek -> DayOfWeek -> DayOfWeek
$cmin :: DayOfWeek -> DayOfWeek -> DayOfWeek
max :: DayOfWeek -> DayOfWeek -> DayOfWeek
$cmax :: DayOfWeek -> DayOfWeek -> DayOfWeek
>= :: DayOfWeek -> DayOfWeek -> Bool
$c>= :: DayOfWeek -> DayOfWeek -> Bool
> :: DayOfWeek -> DayOfWeek -> Bool
$c> :: DayOfWeek -> DayOfWeek -> Bool
<= :: DayOfWeek -> DayOfWeek -> Bool
$c<= :: DayOfWeek -> DayOfWeek -> Bool
< :: DayOfWeek -> DayOfWeek -> Bool
$c< :: DayOfWeek -> DayOfWeek -> Bool
compare :: DayOfWeek -> DayOfWeek -> Ordering
$ccompare :: DayOfWeek -> DayOfWeek -> Ordering
Ord, Int -> DayOfWeek -> String -> String
[DayOfWeek] -> String -> String
DayOfWeek -> String
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)
instance Enum DayOfWeek where
toEnum :: Int -> DayOfWeek
toEnum :: Int -> DayOfWeek
toEnum Int
i = case forall a. Integral a => a -> a -> a
mod Int
i Int
7 of
Int
0 -> DayOfWeek
Sunday
Int
1 -> DayOfWeek
Monday
Int
2 -> DayOfWeek
Tuesday
Int
3 -> DayOfWeek
Wednesday
Int
4 -> DayOfWeek
Thursday
Int
5 -> DayOfWeek
Friday
Int
_ -> DayOfWeek
Saturday
fromEnum :: DayOfWeek -> Int
fromEnum :: DayOfWeek -> Int
fromEnum = \case
DayOfWeek
Monday -> Int
1
DayOfWeek
Tuesday -> Int
2
DayOfWeek
Wednesday -> Int
3
DayOfWeek
Thursday -> Int
4
DayOfWeek
Friday -> Int
5
DayOfWeek
Saturday -> Int
6
DayOfWeek
Sunday -> Int
7
data Note
= Scheduled String Time Priority
| Deadline String Time Priority
| NormalMsg String Priority
deriving (Note -> Note -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Note -> Note -> Bool
$c/= :: Note -> Note -> Bool
== :: Note -> Note -> Bool
$c== :: Note -> Note -> Bool
Eq, Int -> Note -> String -> String
[Note] -> String -> String
Note -> String
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)
data Priority = A | B | C | NoPriority
deriving (Priority -> Priority -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Priority -> Priority -> Bool
$c/= :: Priority -> Priority -> Bool
== :: Priority -> Priority -> Bool
$c== :: Priority -> Priority -> Bool
Eq, Int -> Priority -> String -> String
[Priority] -> String -> String
Priority -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Priority] -> String -> String
$cshowList :: [Priority] -> String -> String
show :: Priority -> String
$cshow :: Priority -> String
showsPrec :: Int -> Priority -> String -> String
$cshowsPrec :: Int -> Priority -> String -> String
Show)
ppNote :: Clp -> String -> Note -> IO String
ppNote :: Clp -> String -> Note -> IO String
ppNote Clp
clp String
todo = \case
Scheduled String
str Time
time Priority
prio -> String -> String -> Maybe Time -> Priority -> IO String
mkLine String
str String
"SCHEDULED: " (forall a. a -> Maybe a
Just Time
time) Priority
prio
Deadline String
str Time
time Priority
prio -> String -> String -> Maybe Time -> Priority -> IO String
mkLine String
str String
"DEADLINE: " (forall a. a -> Maybe a
Just Time
time) Priority
prio
NormalMsg String
str Priority
prio -> String -> String -> Maybe Time -> Priority -> IO String
mkLine String
str String
"" forall a. Maybe a
Nothing Priority
prio
where
mkLine :: String -> String -> Maybe Time -> Priority -> IO String
mkLine :: String -> String -> Maybe Time -> Priority -> IO String
mkLine String
str String
sched Maybe Time
time Priority
prio = do
String
t <- case Maybe Time
time of
Maybe Time
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure String
""
Just Time
ti -> ((String
"\n " forall a. Semigroup a => a -> a -> a
<> String
sched) forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Time -> IO String
ppDate Time
ti
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String
"* " forall a. Semigroup a => a -> a -> a
<> String
todo forall a. Semigroup a => a -> a -> a
<> String
priority forall a. Semigroup a => a -> a -> a
<> case Clp
clp of
Body String
c -> forall a. Monoid a => [a] -> a
mconcat [String
str, String
t, String
c]
Header String
c -> forall a. Monoid a => [a] -> a
mconcat [String
"[[", String
c, String
"][", String
str,String
"]]", String
t]
where
priority :: String
priority = case Priority
prio of
Priority
NoPriority -> String
" "
Priority
otherPrio -> String
" [#" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Priority
otherPrio forall a. Semigroup a => a -> a -> a
<> String
"] "
pInput :: String -> Maybe Note
pInput :: String -> Maybe Note
pInput String
inp = (forall a. Parser a -> String -> Maybe a
`runParser` String
inp) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Parser a] -> Parser a
choice forall a b. (a -> b) -> a -> b
$
[ String -> Time -> Priority -> Note
Scheduled forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Parser String
getLast String
"+s" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Date -> Maybe TimeOfDay -> Time
Time forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Date
pDate forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe TimeOfDay)
pTimeOfDay) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Priority
pPriority
, String -> Time -> Priority -> Note
Deadline forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Parser String
getLast String
"+d" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Date -> Maybe TimeOfDay -> Time
Time forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Date
pDate forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe TimeOfDay)
pTimeOfDay) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Priority
pPriority
, do String
s <- (Char -> Bool) -> Parser String
munch1 (forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True)
let (String
s', String
p) = forall a. Int -> [a] -> ([a], [a])
splitAt (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s forall a. Num a => a -> a -> a
- Int
3) String
s
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case String -> Maybe Priority
tryPrio String
p of
Just Priority
prio -> String -> Priority -> Note
NormalMsg (Int -> String -> String
dropStripEnd Int
0 String
s') Priority
prio
Maybe Priority
Nothing -> String -> Priority -> Note
NormalMsg String
s Priority
NoPriority
]
where
tryPrio :: String -> Maybe Priority
tryPrio :: String -> Maybe Priority
tryPrio [Char
' ', Char
'#', Char
x]
| Char
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"Aa" :: String) = forall a. a -> Maybe a
Just Priority
A
| Char
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"Bb" :: String) = forall a. a -> Maybe a
Just Priority
B
| Char
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"Cc" :: String) = forall a. a -> Maybe a
Just Priority
C
tryPrio String
_ = forall a. Maybe a
Nothing
dropStripEnd :: Int -> String -> String
dropStripEnd :: Int -> String -> String
dropStripEnd Int
n = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
== Char
' ') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse
getLast :: String -> Parser String
getLast :: String -> Parser String
getLast String
ptn = Int -> String -> String
dropStripEnd (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
ptn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a sep. Parser a -> Parser sep -> Parser [a]
endBy1 (String -> Parser String
go 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 (forall a. Eq a => a -> a -> Bool
/= forall a. [a] -> a
head String
ptn)
String
word <- (Char -> Bool) -> Parser String
munch1 (forall a. Eq a => a -> a -> Bool
/= Char
' ')
forall a. a -> a -> Bool -> a
bool String -> Parser String
go forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
word forall a. Eq a => a -> a -> Bool
== String
ptn) forall a b. (a -> b) -> a -> b
$ String
consumed forall a. Semigroup a => a -> a -> a
<> String
str forall a. Semigroup a => a -> a -> a
<> String
word
pPriority :: Parser Priority
pPriority :: Parser Priority
pPriority = forall a. Parser a -> Parser a -> Parser a
pLast (forall (f :: * -> *) a. Applicative f => a -> f a
pure Priority
NoPriority) forall a b. (a -> b) -> a -> b
$
Parser String
" " forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. [Parser a] -> Parser a
choice
[ Parser String
"#" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Parser String
"A" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser String
"a") forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Priority
A
, Parser String
"#" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Parser String
"B" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser String
"b") forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Priority
B
, Parser String
"#" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Parser String
"C" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser String
"c") forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Priority
C
]
pTimeOfDay :: Parser (Maybe TimeOfDay)
pTimeOfDay :: Parser (Maybe TimeOfDay)
pTimeOfDay = forall a. Parser a -> Parser a -> Parser a
pLast (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$
Parser ()
skipSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. [Parser a] -> Parser a
choice
[ forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Int -> TimeOfDay
TimeOfDay forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Int
pHour forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* String -> Parser String
string String
":" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Int
pMinute)
, forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Int -> TimeOfDay
TimeOfDay forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Int
pHour forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0 )
]
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
pDate :: Parser Date
pDate :: Parser Date
pDate = Parser ()
skipSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. [Parser a] -> Parser a
choice
[ forall a. Parser String -> String -> a -> Parser a
pPrefix Parser String
"tod" String
"ay" Date
Today
, forall a. Parser String -> String -> a -> Parser a
pPrefix Parser String
"tom" String
"orrow" Date
Tomorrow
, DayOfWeek -> Date
Next forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser DayOfWeek
pNext
, (Int, Maybe Int, Maybe Integer) -> Date
Date forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Int, Maybe Int, Maybe Integer)
pDate'
]
where
Parser DayOfWeek
pNext :: Parser DayOfWeek = forall a. [Parser a] -> Parser a
choice
[ forall a. Parser String -> String -> a -> Parser a
pPrefix Parser String
"m" String
"onday" DayOfWeek
Monday , forall a. Parser String -> String -> a -> Parser a
pPrefix Parser String
"tu" String
"esday" DayOfWeek
Tuesday
, forall a. Parser String -> String -> a -> Parser a
pPrefix Parser String
"w" String
"ednesday" DayOfWeek
Wednesday, forall a. Parser String -> String -> a -> Parser a
pPrefix Parser String
"th" String
"ursday" DayOfWeek
Thursday
, forall a. Parser String -> String -> a -> Parser a
pPrefix Parser String
"f" String
"riday" DayOfWeek
Friday , forall a. Parser String -> String -> a -> Parser a
pPrefix Parser String
"sa" String
"turday" DayOfWeek
Saturday
, forall a. Parser String -> String -> a -> Parser a
pPrefix Parser 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
Char
c <- Parser Char
get
if Char
c forall a. Eq a => a -> a -> Bool
== Char
':'
then forall a. Parser a
pfail
else forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
str
pDate' :: Parser (Int, Maybe Int, Maybe Integer)
pDate' :: Parser (Int, Maybe Int, Maybe Integer)
pDate' =
(,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Int -> Parser Int
pNumBetween Int
1 Int
31
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser ()
skipSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. [Parser a] -> Parser a
choice
[ forall a. Parser String -> String -> a -> Parser a
pPrefix Parser String
"ja" String
"nuary" Int
1 , forall a. Parser String -> String -> a -> Parser a
pPrefix Parser String
"f" String
"ebruary" Int
2
, forall a. Parser String -> String -> a -> Parser a
pPrefix Parser String
"mar" String
"ch" Int
3 , forall a. Parser String -> String -> a -> Parser a
pPrefix Parser String
"ap" String
"ril" Int
4
, forall a. Parser String -> String -> a -> Parser a
pPrefix Parser String
"may" String
"" Int
5 , forall a. Parser String -> String -> a -> Parser a
pPrefix Parser String
"jun" String
"e" Int
6
, forall a. Parser String -> String -> a -> Parser a
pPrefix Parser String
"jul" String
"y" Int
7 , forall a. Parser String -> String -> a -> Parser a
pPrefix Parser String
"au" String
"gust" Int
8
, forall a. Parser String -> String -> a -> Parser a
pPrefix Parser String
"s" String
"eptember" Int
9 , forall a. Parser String -> String -> a -> Parser a
pPrefix Parser String
"o" String
"ctober" Int
10
, forall a. Parser String -> String -> a -> Parser a
pPrefix Parser String
"n" String
"ovember" Int
11, forall a. Parser String -> String -> a -> Parser a
pPrefix Parser String
"d" String
"ecember" Int
12
, Parser Int
numWithoutColon
])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser ()
skipSpaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. (Read a, Integral a) => Parser a
num forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Integer
i -> forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Integer
i forall a. Ord a => a -> a -> Bool
>= Integer
25) forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Integer
i)
pPrefix :: Parser String -> String -> a -> Parser a
pPrefix :: forall a. Parser String -> String -> a -> Parser a
pPrefix Parser String
start String
leftover a
ret = do
forall (f :: * -> *) a. Functor f => f a -> f ()
void Parser String
start
String
l <- (Char -> Bool) -> Parser String
munch (forall a. Eq a => a -> a -> Bool
/= Char
' ')
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (String
l forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
leftover)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
ret
pNumBetween :: Int -> Int -> Parser Int
pNumBetween :: Int -> Int -> Parser Int
pNumBetween Int
lo Int
hi = do
Int
n <- forall a. (Read a, Integral a) => Parser a
num
Int
n forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
n forall a. Ord a => a -> a -> Bool
>= Int
lo Bool -> Bool -> Bool
&& Int
n forall a. Ord a => a -> a -> Bool
<= Int
hi)
pLast :: Parser a -> Parser a -> Parser a
pLast :: forall a. Parser a -> Parser a -> Parser a
pLast Parser a
p Parser a
p' = Parser a
p' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser a
p