{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, TupleSections #-}
{-# LANGUAGE DeriveFunctor, LambdaCase, ViewPatterns #-}

module DateParser
       ( DateFormat
       , parseDateFormat
       , german

       , parseDate
       , parseDateWithToday

       , parseHLDate
       , parseHLDateWithToday

       , printDate

       -- * Utilities
       , weekDay
       ) where

import           Control.Applicative hiding (many, some)
import           Data.List
import           Data.Maybe
import           Data.Monoid
import           Data.Ord
import qualified Data.Semigroup as Sem
import           Data.Void

import           Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import           Data.Text.Lazy.Builder (Builder, toLazyText)
import qualified Data.Text.Lazy.Builder as Build
import qualified Data.Text.Lazy.Builder.Int as Build
import           Data.Time.Ext
import           Data.Time.Calendar.WeekDate
import qualified Hledger.Data.Dates as HL
import qualified Hledger.Data.Types as HL
import           Text.Megaparsec
import           Text.Megaparsec.Char
import           Text.Printf (printf, PrintfArg)

newtype DateFormat = DateFormat [DateSpec]
                   deriving (DateFormat -> DateFormat -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DateFormat -> DateFormat -> Bool
$c/= :: DateFormat -> DateFormat -> Bool
== :: DateFormat -> DateFormat -> Bool
$c== :: DateFormat -> DateFormat -> Bool
Eq, Int -> DateFormat -> ShowS
[DateFormat] -> ShowS
DateFormat -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DateFormat] -> ShowS
$cshowList :: [DateFormat] -> ShowS
show :: DateFormat -> String
$cshow :: DateFormat -> String
showsPrec :: Int -> DateFormat -> ShowS
$cshowsPrec :: Int -> DateFormat -> ShowS
Show)

-- TODO Add show instance that corresponds to parsed expression

data DateSpec = DateYear
              | DateYearShort
              | DateMonth
              | DateDay
              | DateString Text
              | DateOptional [DateSpec]
                deriving (Int -> DateSpec -> ShowS
[DateSpec] -> ShowS
DateSpec -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DateSpec] -> ShowS
$cshowList :: [DateSpec] -> ShowS
show :: DateSpec -> String
$cshow :: DateSpec -> String
showsPrec :: Int -> DateSpec -> ShowS
$cshowsPrec :: Int -> DateSpec -> ShowS
Show, DateSpec -> DateSpec -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DateSpec -> DateSpec -> Bool
$c/= :: DateSpec -> DateSpec -> Bool
== :: DateSpec -> DateSpec -> Bool
$c== :: DateSpec -> DateSpec -> Bool
Eq)


parseHLDate :: Day -> Text -> Either Text Day
parseHLDate :: Day -> Text -> Either Text Day
parseHLDate Day
current Text
text = case forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse forall (m :: * -> *). TextParser m SmartDate
HL.smartdate String
"date" Text
text of
  Right SmartDate
res -> case Day -> SmartDate -> EFDay
HL.fixSmartDate Day
current SmartDate
res of
    HL.Exact Day
day -> forall a b. b -> Either a b
Right Day
day
    HL.Flex Day
day -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Date " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show Day
day) forall a. Semigroup a => a -> a -> a
<> Text
" not specified exactly."
  Left ParseErrorBundle Text HledgerParseErrorData
err -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty ParseErrorBundle Text HledgerParseErrorData
err

parseHLDateWithToday :: Text -> IO (Either Text Day)
parseHLDateWithToday :: Text -> IO (Either Text Day)
parseHLDateWithToday Text
text = forall a b c. (a -> b -> c) -> b -> a -> c
flip Day -> Text -> Either Text Day
parseHLDate Text
text forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Day
getLocalDay

-- | Corresponds to %d[.[%m[.[%y]]]]
german :: DateFormat
german :: DateFormat
german = [DateSpec] -> DateFormat
DateFormat
  [ DateSpec
DateDay
  , [DateSpec] -> DateSpec
DateOptional [Text -> DateSpec
DateString Text
"."
                 ,[DateSpec] -> DateSpec
DateOptional [DateSpec
DateMonth
                               ,[DateSpec] -> DateSpec
DateOptional [Text -> DateSpec
DateString Text
"."
                                             ,[DateSpec] -> DateSpec
DateOptional [DateSpec
DateYearShort]]]]]

parseDateFormat :: Text -> Either Text DateFormat
parseDateFormat :: Text -> Either Text DateFormat
parseDateFormat Text
text = case forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse Parser DateFormat
dateSpec String
"date-format" Text
text of
  Left ParseErrorBundle Text Void
err  -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty ParseErrorBundle Text Void
err
  Right DateFormat
res -> forall a b. b -> Either a b
Right DateFormat
res


type Parser = Parsec Void Text

dateSpec :: Parser DateFormat
dateSpec :: Parser DateFormat
dateSpec = [DateSpec] -> DateFormat
DateFormat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser DateSpec
oneTok forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
eof)

oneTok :: Parser DateSpec
oneTok :: Parser DateSpec
oneTok =  forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'%' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser DateSpec
percent
      forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'\\' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser DateSpec
escape
      forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [DateSpec] -> DateSpec
DateOptional forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'[') (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
']') (forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser DateSpec
oneTok)
      forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> DateSpec
DateString forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
noneOf (String
"\\[]%" :: String))

percent :: Parser DateSpec
percent :: Parser DateSpec
percent =  forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'y' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure DateSpec
DateYearShort
       forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'Y' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure DateSpec
DateYear
       forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'm' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure DateSpec
DateMonth
       forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'd' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure DateSpec
DateDay
       forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'%' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> DateSpec
DateString Text
"%")

escape :: Parser DateSpec
escape :: Parser DateSpec
escape =  forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'\\' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> DateSpec
DateString Text
"\\")
      forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'[' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> DateSpec
DateString Text
"[")
      forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
']' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> DateSpec
DateString Text
"]")

-- | Parse text with given format and fill in missing fields with todays date.
parseDateWithToday :: DateFormat -> Text -> IO (Either Text Day)
parseDateWithToday :: DateFormat -> Text -> IO (Either Text Day)
parseDateWithToday DateFormat
spec Text
text = do
  Day
today <- IO Day
getLocalDay
  forall (m :: * -> *) a. Monad m => a -> m a
return (Day -> DateFormat -> Text -> Either Text Day
parseDate Day
today DateFormat
spec Text
text)

parseDate :: Day -> DateFormat -> Text -> Either Text Day
parseDate :: Day -> DateFormat -> Text -> Either Text Day
parseDate Day
current (DateFormat [DateSpec]
spec) Text
text =
  let en :: ParsecT Void Text Identity (Maybe Day)
en = forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Day -> Parser Day
parseEnglish Day
current
      completeIDate :: IncompleteDate (Maybe Int) -> Maybe Day
      completeIDate :: IncompleteDate (Maybe Int) -> Maybe Day
completeIDate IncompleteDate (Maybe Int)
d =
        Direction -> Day -> IncompleteDate (Maybe Int) -> Maybe Day
completeNearDate Direction
Past Day
current IncompleteDate (Maybe Int)
d
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Direction -> Day -> IncompleteDate (Maybe Int) -> Maybe Day
completeNearDate Direction
Future Day
current IncompleteDate (Maybe Int)
d
      num :: ParsecT Void Text Identity (Maybe Day)
num = IncompleteDate (Maybe Int) -> Maybe Day
completeIDate forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. First a -> Maybe a
getFirst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DateSpec] -> Parser (IncompleteDate (First Int))
parseDate' [DateSpec]
spec forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
eof

  in case forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse ((forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ParsecT Void Text Identity (Maybe Day)
en forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity (Maybe Day)
num) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) String
"date" Text
text of
    Left ParseErrorBundle Text Void
err -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty ParseErrorBundle Text Void
err
    Right Maybe Day
Nothing -> forall a b. a -> Either a b
Left Text
"Invalid Date"
    Right (Just Day
d) -> forall a b. b -> Either a b
Right Day
d

-- (y, m, d)
newtype IncompleteDate a = IDate (a, a, a)
                       deriving (NonEmpty (IncompleteDate a) -> IncompleteDate a
IncompleteDate a -> IncompleteDate a -> IncompleteDate a
forall b. Integral b => b -> IncompleteDate a -> IncompleteDate a
forall a.
Semigroup a =>
NonEmpty (IncompleteDate a) -> IncompleteDate a
forall a.
Semigroup a =>
IncompleteDate a -> IncompleteDate a -> IncompleteDate a
forall a b.
(Semigroup a, Integral b) =>
b -> IncompleteDate a -> IncompleteDate a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> IncompleteDate a -> IncompleteDate a
$cstimes :: forall a b.
(Semigroup a, Integral b) =>
b -> IncompleteDate a -> IncompleteDate a
sconcat :: NonEmpty (IncompleteDate a) -> IncompleteDate a
$csconcat :: forall a.
Semigroup a =>
NonEmpty (IncompleteDate a) -> IncompleteDate a
<> :: IncompleteDate a -> IncompleteDate a -> IncompleteDate a
$c<> :: forall a.
Semigroup a =>
IncompleteDate a -> IncompleteDate a -> IncompleteDate a
Sem.Semigroup, IncompleteDate a
[IncompleteDate a] -> IncompleteDate a
IncompleteDate a -> IncompleteDate a -> IncompleteDate a
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall {a}. Monoid a => Semigroup (IncompleteDate a)
forall a. Monoid a => IncompleteDate a
forall a. Monoid a => [IncompleteDate a] -> IncompleteDate a
forall a.
Monoid a =>
IncompleteDate a -> IncompleteDate a -> IncompleteDate a
mconcat :: [IncompleteDate a] -> IncompleteDate a
$cmconcat :: forall a. Monoid a => [IncompleteDate a] -> IncompleteDate a
mappend :: IncompleteDate a -> IncompleteDate a -> IncompleteDate a
$cmappend :: forall a.
Monoid a =>
IncompleteDate a -> IncompleteDate a -> IncompleteDate a
mempty :: IncompleteDate a
$cmempty :: forall a. Monoid a => IncompleteDate a
Monoid, forall a b. a -> IncompleteDate b -> IncompleteDate a
forall a b. (a -> b) -> IncompleteDate a -> IncompleteDate b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> IncompleteDate b -> IncompleteDate a
$c<$ :: forall a b. a -> IncompleteDate b -> IncompleteDate a
fmap :: forall a b. (a -> b) -> IncompleteDate a -> IncompleteDate b
$cfmap :: forall a b. (a -> b) -> IncompleteDate a -> IncompleteDate b
Functor, Int -> IncompleteDate a -> ShowS
forall a. Show a => Int -> IncompleteDate a -> ShowS
forall a. Show a => [IncompleteDate a] -> ShowS
forall a. Show a => IncompleteDate a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IncompleteDate a] -> ShowS
$cshowList :: forall a. Show a => [IncompleteDate a] -> ShowS
show :: IncompleteDate a -> String
$cshow :: forall a. Show a => IncompleteDate a -> String
showsPrec :: Int -> IncompleteDate a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> IncompleteDate a -> ShowS
Show)

data Direction = Future | Past deriving (Direction -> Direction -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Direction -> Direction -> Bool
$c/= :: Direction -> Direction -> Bool
== :: Direction -> Direction -> Bool
$c== :: Direction -> Direction -> Bool
Eq,Int -> Direction -> ShowS
[Direction] -> ShowS
Direction -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Direction] -> ShowS
$cshowList :: [Direction] -> ShowS
show :: Direction -> String
$cshow :: Direction -> String
showsPrec :: Int -> Direction -> ShowS
$cshowsPrec :: Int -> Direction -> ShowS
Show)
-- find a date that matches the incomplete date and is as near as possible to
-- the current date in the given direction (Future means only today and in the
-- future; Past means only today and in the past).
completeNearDate :: Direction -> Day  -> IncompleteDate (Maybe Int) -> Maybe Day
completeNearDate :: Direction -> Day -> IncompleteDate (Maybe Int) -> Maybe Day
completeNearDate Direction
dir Day
current (IDate (Maybe Int
i_year,Maybe Int
i_month,Maybe Int
i_day)) =
  let
    sign :: Integer
sign = if Direction
dir forall a. Eq a => a -> a -> Bool
== Direction
Past then -Integer
1 else Integer
1
    (Integer
currentYear, Int
_, Int
_) = Day -> (Integer, Int, Int)
toGregorian Day
current
    singleton :: a -> [a]
singleton a
a = [a
a]
    withDefaultRange :: Maybe a -> [a] -> [a]
    withDefaultRange :: forall a. Maybe a -> [a] -> [a]
withDefaultRange Maybe a
maybe_value [a]
range =
      forall a. a -> Maybe a -> a
fromMaybe
        (if Direction
dir forall a. Eq a => a -> a -> Bool
== Direction
Past then forall a. [a] -> [a]
reverse [a]
range else [a]
range)
        (forall {a}. a -> [a]
singleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
maybe_value)
  in forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ do
    -- every date occours at least once in 8 years
    -- That is because the years divisible by 100 but not by 400 are no leap
    -- years. Depending on dir, choose the past or the next 8 years
    Integer
y <- (forall a. Integral a => a -> Integer
toInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
i_year) forall a. Maybe a -> [a] -> [a]
`withDefaultRange`
            [Integer
currentYear forall a. Num a => a -> a -> a
+ Integer
signforall a. Num a => a -> a -> a
*Integer
4 forall a. Num a => a -> a -> a
- Integer
4 .. Integer
currentYear forall a. Num a => a -> a -> a
+ Integer
signforall a. Num a => a -> a -> a
*Integer
4 forall a. Num a => a -> a -> a
+ Integer
4]
    Int
m <- Maybe Int
i_month  forall a. Maybe a -> [a] -> [a]
`withDefaultRange` [Int
1..Int
12]
    Int
d <- Maybe Int
i_day    forall a. Maybe a -> [a] -> [a]
`withDefaultRange` [Int
1..Int
31]
    Day
completed <- forall a. Maybe a -> [a]
maybeToList (Integer -> Int -> Int -> Maybe Day
fromGregorianValid Integer
y Int
m Int
d)
    if ((Day
completed Day -> Day -> Integer
`diffDays` Day
current) forall a. Num a => a -> a -> a
* Integer
sign forall a. Ord a => a -> a -> Bool
>= Integer
0)
    then forall (m :: * -> *) a. Monad m => a -> m a
return Day
completed
    else forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Completed day not the " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Direction
dir forall a. [a] -> [a] -> [a]
++ String
"."


parseDate' :: [DateSpec] -> Parser (IncompleteDate (First Int))
parseDate' :: [DateSpec] -> Parser (IncompleteDate (First Int))
parseDate' [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
parseDate' (DateSpec
d:[DateSpec]
ds) = case DateSpec
d of
  DateOptional [DateSpec]
sub -> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (forall a. Semigroup a => a -> a -> a
(<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DateSpec] -> Parser (IncompleteDate (First Int))
parseDate' [DateSpec]
sub forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [DateSpec] -> Parser (IncompleteDate (First Int))
parseDate' [DateSpec]
ds)
                  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [DateSpec] -> Parser (IncompleteDate (First Int))
parseDate' [DateSpec]
ds

  DateSpec
_ -> forall a. Semigroup a => a -> a -> a
(<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DateSpec -> Parser (IncompleteDate (First Int))
parseDate1 DateSpec
d forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [DateSpec] -> Parser (IncompleteDate (First Int))
parseDate' [DateSpec]
ds


parseDate1 :: DateSpec -> Parser (IncompleteDate (First Int))
parseDate1 :: DateSpec -> Parser (IncompleteDate (First Int))
parseDate1 DateSpec
ds = case DateSpec
ds of
  DateSpec
DateYear      -> forall {a}.
(First Int -> (a, a, a))
-> ParsecT Void Text Identity (IncompleteDate a)
part (,forall a. Monoid a => a
mempty,forall a. Monoid a => a
mempty)
  DateSpec
DateYearShort -> forall {a}.
(First Int -> (a, a, a))
-> ParsecT Void Text Identity (IncompleteDate a)
part forall a b. (a -> b) -> a -> b
$ (,forall a. Monoid a => a
mempty,forall a. Monoid a => a
mempty) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a}. (Ord a, Num a) => a -> a
completeYear
  DateSpec
DateMonth     -> forall {a}.
(First Int -> (a, a, a))
-> ParsecT Void Text Identity (IncompleteDate a)
part (forall a. Monoid a => a
mempty,,forall a. Monoid a => a
mempty)
  DateSpec
DateDay       -> forall {a}.
(First Int -> (a, a, a))
-> ParsecT Void Text Identity (IncompleteDate a)
part (forall a. Monoid a => a
mempty,forall a. Monoid a => a
mempty,)
  DateString Text
s  -> forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Text
s forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
  DateOptional [DateSpec]
ds' -> forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option forall a. Monoid a => a
mempty (forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ [DateSpec] -> Parser (IncompleteDate (First Int))
parseDate' [DateSpec]
ds')

  where digits :: ParsecT Void Text Identity [Token Text]
digits = forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar
        part :: (First Int -> (a, a, a))
-> ParsecT Void Text Identity (IncompleteDate a)
part First Int -> (a, a, a)
f = forall a. (a, a, a) -> IncompleteDate a
IDate forall b c a. (b -> c) -> (a -> b) -> a -> c
. First Int -> (a, a, a)
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Maybe a -> First a
First forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Read a => String -> a
read :: String -> Int)  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity [Token Text]
digits
        completeYear :: a -> a
completeYear a
year
          | a
year forall a. Ord a => a -> a -> Bool
< a
100 = a
year forall a. Num a => a -> a -> a
+ a
2000
          | Bool
otherwise  = a
year


-- Parses an english word such as 'yesterday' or 'monday'
parseEnglish :: Day -> Parser Day
parseEnglish :: Day -> Parser Day
parseEnglish Day
current = (forall a b. (a -> b) -> a -> b
$ Day
current) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ([ParsecT Void Text Identity (Day -> Day)]
relativeDays forall a. [a] -> [a] -> [a]
++ [ParsecT Void Text Identity (Day -> Day)]
weekDays)

relativeDays :: [Parser (Day -> Day)]
relativeDays :: [ParsecT Void Text Identity (Day -> Day)]
relativeDays = forall a b. (a -> b) -> [a] -> [b]
map forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try
  [ Integer -> Day -> Day
addDays Integer
1    forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"tomorrow"
  , forall a. a -> a
id           forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"today"
  , Integer -> Day -> Day
addDays (-Integer
1) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"yesterday"
  , Integer -> Day -> Day
addDays (-Integer
1) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"yest"
  ]

weekDays :: [Parser (Day -> Day)]
weekDays :: [ParsecT Void Text Identity (Day -> Day)]
weekDays = forall a b. (a -> b) -> [a] -> [b]
map (\(Int
i, Text
name) -> Int -> Day -> Day
weekDay Int
i forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Text
name)) [(Int, Text)]
sortedDays
  where -- sort the days so that the parser finds the longest match
        sortedDays :: [(Int, Text)]
        sortedDays :: [(Int, Text)]
sortedDays = forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (forall a. a -> Down a
Down forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Int
T.length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Int, Text)]
flattenedDays
        flattenedDays :: [(Int, Text)]
        flattenedDays :: [(Int, Text)]
flattenedDays = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Int
i, [Text]
xs) -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int
i,) [Text]
xs) [(Int, [Text])]
days
        days :: [(Int, [Text])]
        days :: [(Int, [Text])]
days = [ (Int
1, [Text
"monday", Text
"mon"])
               , (Int
2, [Text
"tuesday", Text
"tues", Text
"tue"])
               , (Int
3, [Text
"wednesday", Text
"wed"])
               , (Int
4, [Text
"thursday", Text
"thur"])
               , (Int
5, [Text
"friday", Text
"fri"])
               , (Int
6, [Text
"saturday", Text
"sat"])
               , (Int
7, [Text
"sunday", Text
"sun"])
               ]

-- | Computes a relative date by the given weekday
--
-- Returns the first weekday with index wday, that's before the current date.
weekDay :: Int -> Day -> Day
weekDay :: Int -> Day -> Day
weekDay Int
wday Day
current =
  let (Integer
_, Int
_, Int
wday') = Day -> (Integer, Int, Int)
toWeekDate Day
current
      difference :: Int
difference = forall a. Num a => a -> a
negate forall a b. (a -> b) -> a -> b
$ (Int
wday' forall a. Num a => a -> a -> a
- Int
wday) forall a. Integral a => a -> a -> a
`mod` Int
7
  in Integer -> Day -> Day
addDays (forall a. Integral a => a -> Integer
toInteger Int
difference) Day
current


printDate :: DateFormat -> Day -> Text
printDate :: DateFormat -> Day -> Text
printDate (DateFormat [DateSpec]
spec) Day
day = Text -> Text
TL.toStrict forall a b. (a -> b) -> a -> b
$ Builder -> Text
toLazyText forall a b. (a -> b) -> a -> b
$ [DateSpec] -> Day -> Builder
printDate' [DateSpec]
spec Day
day

printDate' :: [DateSpec] -> Day -> Builder
printDate' :: [DateSpec] -> Day -> Builder
printDate' [] Day
_ = Builder
""
printDate' (DateSpec
DateYear:[DateSpec]
ds) day :: Day
day@(Day -> (Integer, Int, Int)
toGregorian -> (Integer
y,Int
_,Int
_)) =
  forall a. Integral a => a -> Builder
Build.decimal Integer
y forall a. Semigroup a => a -> a -> a
<> [DateSpec] -> Day -> Builder
printDate' [DateSpec]
ds Day
day
printDate' (DateSpec
DateYearShort:[DateSpec]
ds) day :: Day
day@(Day -> (Integer, Int, Int)
toGregorian -> (Integer
y,Int
_,Int
_))
  | Integer
y forall a. Ord a => a -> a -> Bool
> Integer
2000  = forall a. (Integral a, PrintfArg a) => a -> Builder
twoDigits (Integer
yforall a. Num a => a -> a -> a
-Integer
2000) forall a. Semigroup a => a -> a -> a
<> [DateSpec] -> Day -> Builder
printDate' [DateSpec]
ds Day
day
  | Bool
otherwise = forall a. (Integral a, PrintfArg a) => a -> Builder
twoDigits Integer
y forall a. Semigroup a => a -> a -> a
<> [DateSpec] -> Day -> Builder
printDate' [DateSpec]
ds Day
day
printDate' (DateSpec
DateMonth:[DateSpec]
ds) day :: Day
day@(Day -> (Integer, Int, Int)
toGregorian -> (Integer
_,Int
m,Int
_)) =
  forall a. (Integral a, PrintfArg a) => a -> Builder
twoDigits Int
m forall a. Semigroup a => a -> a -> a
<> [DateSpec] -> Day -> Builder
printDate' [DateSpec]
ds Day
day
printDate' (DateSpec
DateDay:[DateSpec]
ds) day :: Day
day@(Day -> (Integer, Int, Int)
toGregorian -> (Integer
_,Int
_,Int
d)) =
  forall a. (Integral a, PrintfArg a) => a -> Builder
twoDigits Int
d forall a. Semigroup a => a -> a -> a
<> [DateSpec] -> Day -> Builder
printDate' [DateSpec]
ds Day
day
printDate' (DateString Text
s:[DateSpec]
ds) Day
day =
  Text -> Builder
Build.fromText Text
s forall a. Semigroup a => a -> a -> a
<> [DateSpec] -> Day -> Builder
printDate' [DateSpec]
ds Day
day
printDate' (DateOptional [DateSpec]
opt:[DateSpec]
ds) Day
day =
  [DateSpec] -> Day -> Builder
printDate' [DateSpec]
opt Day
day forall a. Semigroup a => a -> a -> a
<> [DateSpec] -> Day -> Builder
printDate' [DateSpec]
ds Day
day

twoDigits :: (Integral a, PrintfArg a) => a -> Builder
twoDigits :: forall a. (Integral a, PrintfArg a) => a -> Builder
twoDigits = String -> Builder
Build.fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. PrintfType r => String -> r
printf String
"%02d"