{-# 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 hiding (parseTime)
import           Data.Time.Calendar.WeekDate
import qualified Hledger.Data.Dates as HL
import           Text.Megaparsec
import           Text.Megaparsec.Char
import           Text.Printf (printf, PrintfArg)

newtype DateFormat = DateFormat [DateSpec]
                   deriving (DateFormat -> DateFormat -> Bool
(DateFormat -> DateFormat -> Bool)
-> (DateFormat -> DateFormat -> Bool) -> Eq DateFormat
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
(Int -> DateFormat -> ShowS)
-> (DateFormat -> String)
-> ([DateFormat] -> ShowS)
-> Show DateFormat
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
(Int -> DateSpec -> ShowS)
-> (DateSpec -> String) -> ([DateSpec] -> ShowS) -> Show DateSpec
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
(DateSpec -> DateSpec -> Bool)
-> (DateSpec -> DateSpec -> Bool) -> Eq DateSpec
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 Parsec CustomErr Text SmartDate
-> String
-> Text
-> Either (ParseErrorBundle Text CustomErr) SmartDate
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse Parsec CustomErr Text SmartDate
forall (m :: * -> *). TextParser m SmartDate
HL.smartdate String
"date" Text
text of
  Right SmartDate
res -> Day -> Either Text Day
forall a b. b -> Either a b
Right (Day -> Either Text Day) -> Day -> Either Text Day
forall a b. (a -> b) -> a -> b
$ Day -> SmartDate -> Day
HL.fixSmartDate Day
current SmartDate
res
  Left ParseErrorBundle Text CustomErr
err -> Text -> Either Text Day
forall a b. a -> Either a b
Left (Text -> Either Text Day) -> Text -> Either Text Day
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle Text CustomErr -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty ParseErrorBundle Text CustomErr
err

parseHLDateWithToday :: Text -> IO (Either Text Day)
parseHLDateWithToday :: Text -> IO (Either Text Day)
parseHLDateWithToday Text
text = (Day -> Text -> Either Text Day) -> Text -> Day -> Either Text Day
forall a b c. (a -> b -> c) -> b -> a -> c
flip Day -> Text -> Either Text Day
parseHLDate Text
text (Day -> Either Text Day) -> IO Day -> IO (Either Text Day)
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 Parsec Void Text DateFormat
-> String -> Text -> Either (ParseErrorBundle Text Void) DateFormat
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse Parsec Void Text DateFormat
dateSpec String
"date-format" Text
text of
  Left ParseErrorBundle Text Void
err  -> Text -> Either Text DateFormat
forall a b. a -> Either a b
Left (Text -> Either Text DateFormat) -> Text -> Either Text DateFormat
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle Text Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty ParseErrorBundle Text Void
err
  Right DateFormat
res -> DateFormat -> Either Text DateFormat
forall a b. b -> Either a b
Right DateFormat
res


type Parser = Parsec Void Text

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

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

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

escape :: Parser DateSpec
escape :: ParsecT Void Text Identity DateSpec
escape =  Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'\\' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity DateSpec
-> ParsecT Void Text Identity DateSpec
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> DateSpec -> ParsecT Void Text Identity DateSpec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> DateSpec
DateString Text
"\\")
      ParsecT Void Text Identity DateSpec
-> ParsecT Void Text Identity DateSpec
-> ParsecT Void Text Identity DateSpec
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'[' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity DateSpec
-> ParsecT Void Text Identity DateSpec
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> DateSpec -> ParsecT Void Text Identity DateSpec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> DateSpec
DateString Text
"[")
      ParsecT Void Text Identity DateSpec
-> ParsecT Void Text Identity DateSpec
-> ParsecT Void Text Identity DateSpec
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
']' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity DateSpec
-> ParsecT Void Text Identity DateSpec
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> DateSpec -> ParsecT Void Text Identity DateSpec
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
  Either Text Day -> IO (Either Text Day)
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 = Day -> Maybe Day
forall a. a -> Maybe a
Just (Day -> Maybe Day)
-> ParsecT Void Text Identity Day
-> ParsecT Void Text Identity (Maybe Day)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Day -> ParsecT Void Text Identity 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
        Maybe Day -> Maybe Day -> Maybe Day
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 (IncompleteDate (Maybe Int) -> Maybe Day)
-> (IncompleteDate (First Int) -> IncompleteDate (Maybe Int))
-> IncompleteDate (First Int)
-> Maybe Day
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (First Int -> Maybe Int)
-> IncompleteDate (First Int) -> IncompleteDate (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap First Int -> Maybe Int
forall a. First a -> Maybe a
getFirst (IncompleteDate (First Int) -> Maybe Day)
-> ParsecT Void Text Identity (IncompleteDate (First Int))
-> ParsecT Void Text Identity (Maybe Day)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DateSpec]
-> ParsecT Void Text Identity (IncompleteDate (First Int))
parseDate' [DateSpec]
spec ParsecT Void Text Identity (Maybe Day)
-> ParsecT Void Text Identity ()
-> ParsecT Void Text Identity (Maybe Day)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof

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

-- (y, m, d)
newtype IncompleteDate a = IDate (a, a, a)
                       deriving (b -> IncompleteDate a -> IncompleteDate a
NonEmpty (IncompleteDate a) -> IncompleteDate a
IncompleteDate a -> IncompleteDate a -> IncompleteDate a
(IncompleteDate a -> IncompleteDate a -> IncompleteDate a)
-> (NonEmpty (IncompleteDate a) -> IncompleteDate a)
-> (forall b.
    Integral b =>
    b -> IncompleteDate a -> IncompleteDate a)
-> Semigroup (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 :: 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, Semigroup (IncompleteDate a)
IncompleteDate a
Semigroup (IncompleteDate a)
-> IncompleteDate a
-> (IncompleteDate a -> IncompleteDate a -> IncompleteDate a)
-> ([IncompleteDate a] -> IncompleteDate a)
-> Monoid (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
$cp1Monoid :: forall a. Monoid a => Semigroup (IncompleteDate a)
Monoid, a -> IncompleteDate b -> IncompleteDate a
(a -> b) -> IncompleteDate a -> IncompleteDate b
(forall a b. (a -> b) -> IncompleteDate a -> IncompleteDate b)
-> (forall a b. a -> IncompleteDate b -> IncompleteDate a)
-> Functor IncompleteDate
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
<$ :: a -> IncompleteDate b -> IncompleteDate a
$c<$ :: forall a b. a -> IncompleteDate b -> IncompleteDate a
fmap :: (a -> b) -> IncompleteDate a -> IncompleteDate b
$cfmap :: forall a b. (a -> b) -> IncompleteDate a -> IncompleteDate b
Functor, Int -> IncompleteDate a -> ShowS
[IncompleteDate a] -> ShowS
IncompleteDate a -> String
(Int -> IncompleteDate a -> ShowS)
-> (IncompleteDate a -> String)
-> ([IncompleteDate a] -> ShowS)
-> Show (IncompleteDate a)
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
(Direction -> Direction -> Bool)
-> (Direction -> Direction -> Bool) -> Eq Direction
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
(Int -> Direction -> ShowS)
-> (Direction -> String)
-> ([Direction] -> ShowS)
-> Show Direction
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 Direction -> Direction -> Bool
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 :: Maybe a -> [a] -> [a]
withDefaultRange Maybe a
maybe_value [a]
range =
      [a] -> Maybe [a] -> [a]
forall a. a -> Maybe a -> a
fromMaybe
        (if Direction
dir Direction -> Direction -> Bool
forall a. Eq a => a -> a -> Bool
== Direction
Past then [a] -> [a]
forall a. [a] -> [a]
reverse [a]
range else [a]
range)
        (a -> [a]
forall a. a -> [a]
singleton (a -> [a]) -> Maybe a -> Maybe [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
maybe_value)
  in [Day] -> Maybe Day
forall a. [a] -> Maybe a
listToMaybe ([Day] -> Maybe Day) -> [Day] -> Maybe Day
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 <- (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Maybe Int -> Maybe Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
i_year) Maybe Integer -> [Integer] -> [Integer]
forall a. Maybe a -> [a] -> [a]
`withDefaultRange`
            [Integer
currentYear Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
signInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
4 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
4 .. Integer
currentYear Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
signInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
4 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
4]
    Int
m <- Maybe Int
i_month  Maybe Int -> [Int] -> [Int]
forall a. Maybe a -> [a] -> [a]
`withDefaultRange` [Int
1..Int
12]
    Int
d <- Maybe Int
i_day    Maybe Int -> [Int] -> [Int]
forall a. Maybe a -> [a] -> [a]
`withDefaultRange` [Int
1..Int
31]
    Day
completed <- Maybe Day -> [Day]
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) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
sign Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0)
    then Day -> [Day]
forall (m :: * -> *) a. Monad m => a -> m a
return Day
completed
    else String -> [Day]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> [Day]) -> String -> [Day]
forall a b. (a -> b) -> a -> b
$ String
"Completed day not the " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Direction -> String
forall a. Show a => a -> String
show Direction
dir String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."


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

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


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

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


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

relativeDays :: [Parser (Day -> Day)]
relativeDays :: [ParsecT Void Text Identity (Day -> Day)]
relativeDays = (ParsecT Void Text Identity (Day -> Day)
 -> ParsecT Void Text Identity (Day -> Day))
-> [ParsecT Void Text Identity (Day -> Day)]
-> [ParsecT Void Text Identity (Day -> Day)]
forall a b. (a -> b) -> [a] -> [b]
map ParsecT Void Text Identity (Day -> Day)
-> ParsecT Void Text Identity (Day -> Day)
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try
  [ Integer -> Day -> Day
addDays Integer
1    (Day -> Day)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Day -> Day)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"tomorrow"
  , Day -> Day
forall a. a -> a
id           (Day -> Day)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Day -> Day)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"today"
  , Integer -> Day -> Day
addDays (-Integer
1) (Day -> Day)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Day -> Day)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"yesterday"
  , Integer -> Day -> Day
addDays (-Integer
1) (Day -> Day)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Day -> Day)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
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 = ((Int, Text) -> ParsecT Void Text Identity (Day -> Day))
-> [(Int, Text)] -> [ParsecT Void Text Identity (Day -> Day)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
i, Text
name) -> Int -> Day -> Day
weekDay Int
i (Day -> Day)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Day -> Day)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Text
Tokens Text
name)) [(Int, Text)]
sortedDays
  where -- sort the days so that the parser finds the longest match
        sortedDays :: [(Int, Text)]
        sortedDays :: [(Int, Text)]
sortedDays = ((Int, Text) -> Down Int) -> [(Int, Text)] -> [(Int, Text)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Int -> Down Int
forall a. a -> Down a
Down (Int -> Down Int)
-> ((Int, Text) -> Int) -> (Int, Text) -> Down Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Int
T.length (Text -> Int) -> ((Int, Text) -> Text) -> (Int, Text) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Text) -> Text
forall a b. (a, b) -> b
snd) [(Int, Text)]
flattenedDays
        flattenedDays :: [(Int, Text)]
        flattenedDays :: [(Int, Text)]
flattenedDays = ((Int, [Text]) -> [(Int, Text)])
-> [(Int, [Text])] -> [(Int, Text)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Int
i, [Text]
xs) -> (Text -> (Int, Text)) -> [Text] -> [(Int, Text)]
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 = Int -> Int
forall a. Num a => a -> a
negate (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ (Int
wday' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
wday) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
7
  in Integer -> Day -> Day
addDays (Int -> Integer
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 (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Builder -> Text
toLazyText (Builder -> Text) -> Builder -> Text
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
_)) =
  Integer -> Builder
forall a. Integral a => a -> Builder
Build.decimal Integer
y Builder -> Builder -> Builder
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 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
2000  = Integer -> Builder
forall a. (Integral a, PrintfArg a) => a -> Builder
twoDigits (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
2000) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [DateSpec] -> Day -> Builder
printDate' [DateSpec]
ds Day
day
  | Bool
otherwise = Integer -> Builder
forall a. (Integral a, PrintfArg a) => a -> Builder
twoDigits Integer
y Builder -> Builder -> Builder
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
_)) =
  Int -> Builder
forall a. (Integral a, PrintfArg a) => a -> Builder
twoDigits Int
m Builder -> Builder -> Builder
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)) =
  Int -> Builder
forall a. (Integral a, PrintfArg a) => a -> Builder
twoDigits Int
d Builder -> Builder -> Builder
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 Builder -> Builder -> Builder
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 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [DateSpec] -> Day -> Builder
printDate' [DateSpec]
ds Day
day

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