module Taskell.Data.Date.RelativeParser
    ( parseRelative
    ) where

import ClassyPrelude

import Data.Attoparsec.Text

import Data.Time.Clock (addUTCTime)

import Taskell.Data.Date.Types (Due (DueDate, DueTime))
import Taskell.Utility.Parser  (lexeme, only)

-- utility functions
addP :: (Integral a) => Parser a -> UTCTime -> Parser UTCTime
addP :: Parser a -> UTCTime -> Parser UTCTime
addP Parser a
p UTCTime
now = ((UTCTime -> UTCTime) -> UTCTime -> UTCTime
forall a b. (a -> b) -> a -> b
$ UTCTime
now) ((UTCTime -> UTCTime) -> UTCTime)
-> ([a] -> UTCTime -> UTCTime) -> [a] -> UTCTime
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (NominalDiffTime -> UTCTime -> UTCTime)
-> ([a] -> NominalDiffTime) -> [a] -> UTCTime -> UTCTime
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> NominalDiffTime) -> ([a] -> a) -> [a] -> NominalDiffTime
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [a] -> a
forall mono.
(MonoFoldable mono, Num (Element mono)) =>
mono -> Element mono
sum ([a] -> UTCTime) -> Parser Text [a] -> Parser UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a -> Parser Text [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many1 Parser a
p

-- relative time parsing
minute :: Int
minute :: Int
minute = Int
60

hour :: Int
hour :: Int
hour = Int
minute Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60

day :: Int
day :: Int
day = Int
hour Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
24

week :: Int
week :: Int
week = Int
day Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
7

timePeriodP :: Char -> Parser Int
timePeriodP :: Char -> Parser Int
timePeriodP Char
c = Parser Int -> Parser Int
forall a. Parser a -> Parser a
lexeme Parser Int
forall a. Integral a => Parser a
decimal Parser Int -> Parser Text Char -> Parser Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Text Char
char Char
c

wP :: Parser Int
wP :: Parser Int
wP = (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
week) (Int -> Int) -> Parser Int -> Parser Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Parser Int
timePeriodP Char
'w'

dP :: Parser Int
dP :: Parser Int
dP = (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
day) (Int -> Int) -> Parser Int -> Parser Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Parser Int
timePeriodP Char
'd'

hP :: Parser Int
hP :: Parser Int
hP = (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
hour) (Int -> Int) -> Parser Int -> Parser Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Parser Int
timePeriodP Char
'h'

mP :: Parser Int
mP :: Parser Int
mP = (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
minute) (Int -> Int) -> Parser Int -> Parser Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Parser Int
timePeriodP Char
'm'

sP :: Parser Int
sP :: Parser Int
sP = Char -> Parser Int
timePeriodP Char
's'

timeP :: UTCTime -> Parser (Maybe Due)
timeP :: UTCTime -> Parser (Maybe Due)
timeP UTCTime
now = Parser (Maybe Due) -> Parser (Maybe Due)
forall a. Parser a -> Parser a
only (Parser (Maybe Due) -> Parser (Maybe Due))
-> (Parser (Maybe Due) -> Parser (Maybe Due))
-> Parser (Maybe Due)
-> Parser (Maybe Due)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Parser (Maybe Due) -> Parser (Maybe Due)
forall a. Parser a -> Parser a
lexeme (Parser (Maybe Due) -> Parser (Maybe Due))
-> Parser (Maybe Due) -> Parser (Maybe Due)
forall a b. (a -> b) -> a -> b
$ Due -> Maybe Due
forall a. a -> Maybe a
Just (Due -> Maybe Due) -> (UTCTime -> Due) -> UTCTime -> Maybe Due
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. UTCTime -> Due
DueTime (UTCTime -> Maybe Due) -> Parser UTCTime -> Parser (Maybe Due)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Int -> UTCTime -> Parser UTCTime
forall a. Integral a => Parser a -> UTCTime -> Parser UTCTime
addP (Parser Int
sP Parser Int -> Parser Int -> Parser Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Int
mP Parser Int -> Parser Int -> Parser Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Int
hP Parser Int -> Parser Int -> Parser Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Int
dP Parser Int -> Parser Int -> Parser Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Int
wP) UTCTime
now

-- relative date parsing
dateP :: UTCTime -> Parser (Maybe Due)
dateP :: UTCTime -> Parser (Maybe Due)
dateP UTCTime
now = Parser (Maybe Due) -> Parser (Maybe Due)
forall a. Parser a -> Parser a
only (Parser (Maybe Due) -> Parser (Maybe Due))
-> (Parser (Maybe Due) -> Parser (Maybe Due))
-> Parser (Maybe Due)
-> Parser (Maybe Due)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Parser (Maybe Due) -> Parser (Maybe Due)
forall a. Parser a -> Parser a
lexeme (Parser (Maybe Due) -> Parser (Maybe Due))
-> Parser (Maybe Due) -> Parser (Maybe Due)
forall a b. (a -> b) -> a -> b
$ Due -> Maybe Due
forall a. a -> Maybe a
Just (Due -> Maybe Due) -> (UTCTime -> Due) -> UTCTime -> Maybe Due
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Day -> Due
DueDate (Day -> Due) -> (UTCTime -> Day) -> UTCTime -> Due
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. UTCTime -> Day
utctDay (UTCTime -> Maybe Due) -> Parser UTCTime -> Parser (Maybe Due)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Int -> UTCTime -> Parser UTCTime
forall a. Integral a => Parser a -> UTCTime -> Parser UTCTime
addP (Parser Int
dP Parser Int -> Parser Int -> Parser Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Int
wP) UTCTime
now

-- relative parser
relativeP :: UTCTime -> Parser (Maybe Due)
relativeP :: UTCTime -> Parser (Maybe Due)
relativeP UTCTime
now = UTCTime -> Parser (Maybe Due)
dateP UTCTime
now Parser (Maybe Due) -> Parser (Maybe Due) -> Parser (Maybe Due)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> UTCTime -> Parser (Maybe Due)
timeP UTCTime
now

parseRelative :: UTCTime -> Text -> Either Text Due
parseRelative :: UTCTime -> Text -> Either Text Due
parseRelative UTCTime
now Text
text =
    case Parser (Maybe Due) -> Text -> Either String (Maybe Due)
forall a. Parser a -> Text -> Either String a
parseOnly (UTCTime -> Parser (Maybe Due)
relativeP UTCTime
now) Text
text of
        Right (Just Due
due) -> Due -> Either Text Due
forall a b. b -> Either a b
Right Due
due
        Either String (Maybe Due)
_                -> Text -> Either Text Due
forall a b. a -> Either a b
Left Text
"Could not parse date."