{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}

module Data.FuzzyTime.Parser
  ( fuzzyLocalTimeP,
    fuzzyTimeOfDayP,
    atHourP,
    atMinuteP,
    atExactP,
    hourSegmentP,
    minuteSegmentP,
    twoDigitsSegmentP,
    fuzzyDayP,
    fuzzyDayOfTheWeekP,
    Parser,
  )
where

import Control.Monad (guard, msum, void)
import Data.Char as Char (toLower)
import Data.Fixed (Pico)
import Data.FuzzyTime.Types (FuzzyDay (..), FuzzyLocalTime (..), FuzzyTimeOfDay (AtExact, AtHour, AtMinute, Evening, HoursDiff, Midnight, MinutesDiff, Morning, Noon, SecondsDiff))
import Data.List (find)
import Data.Maybe (fromMaybe, maybeToList)
import Data.Text (Text)
import Data.Time (DayOfWeek (..), TimeOfDay (TimeOfDay), defaultTimeLocale, parseTimeM)
import Data.Tree (Forest, Tree (Node), rootLabel, subForest)
import Data.Validity (isValid)
import Data.Void (Void)
import Data.Word (Word8)
import Text.Megaparsec (Parsec, empty, eof, label, oneOf, optional, some, try, (<|>))
import Text.Megaparsec.Char as Char (char, digitChar, letterChar, space1, string)
import Text.Megaparsec.Char.Lexer as Lexer (decimal)
import Text.Read (readMaybe)

type Parser = Parsec Void Text

fuzzyLocalTimeP :: Parser FuzzyLocalTime
fuzzyLocalTimeP :: Parser FuzzyLocalTime
fuzzyLocalTimeP =
  String -> Parser FuzzyLocalTime -> Parser FuzzyLocalTime
forall a.
String
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"FuzzyLocalTime" (Parser FuzzyLocalTime -> Parser FuzzyLocalTime)
-> Parser FuzzyLocalTime -> Parser FuzzyLocalTime
forall a b. (a -> b) -> a -> b
$
    [Parser FuzzyLocalTime] -> Parser FuzzyLocalTime
forall a. [Parser a] -> Parser a
choice''
      [ do
          FuzzyDay
a <- Parser FuzzyDay
fuzzyDayP
          ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space1
          FuzzyTimeOfDay
b <- Parser FuzzyTimeOfDay
fuzzyTimeOfDayP
          FuzzyLocalTime -> Parser FuzzyLocalTime
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FuzzyLocalTime -> Parser FuzzyLocalTime)
-> FuzzyLocalTime -> Parser FuzzyLocalTime
forall a b. (a -> b) -> a -> b
$ FuzzyDay -> FuzzyTimeOfDay -> FuzzyLocalTime
FuzzyLocalTimeBoth FuzzyDay
a FuzzyTimeOfDay
b,
        FuzzyDay -> FuzzyLocalTime
FuzzyLocalTimeDay (FuzzyDay -> FuzzyLocalTime)
-> Parser FuzzyDay -> Parser FuzzyLocalTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser FuzzyDay
fuzzyDayP,
        FuzzyTimeOfDay -> FuzzyLocalTime
FuzzyLocalTimeTimeOfDay (FuzzyTimeOfDay -> FuzzyLocalTime)
-> Parser FuzzyTimeOfDay -> Parser FuzzyLocalTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser FuzzyTimeOfDay
fuzzyTimeOfDayP
      ]

fuzzyTimeOfDayP :: Parser FuzzyTimeOfDay
fuzzyTimeOfDayP :: Parser FuzzyTimeOfDay
fuzzyTimeOfDayP =
  String -> Parser FuzzyTimeOfDay -> Parser FuzzyTimeOfDay
forall a.
String
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"FuzzyTimeOfDay" (Parser FuzzyTimeOfDay -> Parser FuzzyTimeOfDay)
-> Parser FuzzyTimeOfDay -> Parser FuzzyTimeOfDay
forall a b. (a -> b) -> a -> b
$
    [Parser FuzzyTimeOfDay] -> Parser FuzzyTimeOfDay
forall a. [Parser a] -> Parser a
choice'
      [ [(String, FuzzyTimeOfDay)] -> Parser FuzzyTimeOfDay
forall a. [(String, a)] -> Parser a
recTreeParser
          [ (String
"midnight", FuzzyTimeOfDay
Midnight),
            (String
"midday", FuzzyTimeOfDay
Noon),
            (String
"noon", FuzzyTimeOfDay
Noon),
            (String
"morning", FuzzyTimeOfDay
Morning),
            (String
"evening", FuzzyTimeOfDay
Evening)
          ],
        Parser FuzzyTimeOfDay
atExactP,
        Parser FuzzyTimeOfDay
atMinuteP,
        Parser FuzzyTimeOfDay
atHourP,
        Parser FuzzyTimeOfDay
diffP
      ]

atHourP :: Parser FuzzyTimeOfDay
atHourP :: Parser FuzzyTimeOfDay
atHourP =
  String -> Parser FuzzyTimeOfDay -> Parser FuzzyTimeOfDay
forall a.
String
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"AtHour" (Parser FuzzyTimeOfDay -> Parser FuzzyTimeOfDay)
-> Parser FuzzyTimeOfDay -> Parser FuzzyTimeOfDay
forall a b. (a -> b) -> a -> b
$ do
    Int
h <- Parser Int
hourSegmentP
    FuzzyTimeOfDay -> Parser FuzzyTimeOfDay
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FuzzyTimeOfDay -> Parser FuzzyTimeOfDay)
-> FuzzyTimeOfDay -> Parser FuzzyTimeOfDay
forall a b. (a -> b) -> a -> b
$ Int -> FuzzyTimeOfDay
AtHour Int
h

atMinuteP :: Parser FuzzyTimeOfDay
atMinuteP :: Parser FuzzyTimeOfDay
atMinuteP =
  String -> Parser FuzzyTimeOfDay -> Parser FuzzyTimeOfDay
forall a.
String
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"AtMinute" (Parser FuzzyTimeOfDay -> Parser FuzzyTimeOfDay)
-> Parser FuzzyTimeOfDay -> Parser FuzzyTimeOfDay
forall a b. (a -> b) -> a -> b
$ do
    Int
h <- Parser Int
hourSegmentP
    Int
m <- Parser Int
minuteSegmentP
    FuzzyTimeOfDay -> Parser FuzzyTimeOfDay
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FuzzyTimeOfDay -> Parser FuzzyTimeOfDay)
-> FuzzyTimeOfDay -> Parser FuzzyTimeOfDay
forall a b. (a -> b) -> a -> b
$ Int -> Int -> FuzzyTimeOfDay
AtMinute Int
h Int
m

atExactP :: Parser FuzzyTimeOfDay
atExactP :: Parser FuzzyTimeOfDay
atExactP =
  String -> Parser FuzzyTimeOfDay -> Parser FuzzyTimeOfDay
forall a.
String
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"AtExact" (Parser FuzzyTimeOfDay -> Parser FuzzyTimeOfDay)
-> Parser FuzzyTimeOfDay -> Parser FuzzyTimeOfDay
forall a b. (a -> b) -> a -> b
$ do
    Int
h <- Parser Int
hourSegmentP
    Int
m <- Parser Int
minuteSegmentP
    ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Char -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ 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
':'
    Pico
s <- Parser Pico
readSimplePico
    FuzzyTimeOfDay -> Parser FuzzyTimeOfDay
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FuzzyTimeOfDay -> Parser FuzzyTimeOfDay)
-> FuzzyTimeOfDay -> Parser FuzzyTimeOfDay
forall a b. (a -> b) -> a -> b
$ TimeOfDay -> FuzzyTimeOfDay
AtExact (TimeOfDay -> FuzzyTimeOfDay) -> TimeOfDay -> FuzzyTimeOfDay
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Pico -> TimeOfDay
TimeOfDay Int
h Int
m Pico
s

readSimplePico :: Parser Pico
readSimplePico :: Parser Pico
readSimplePico = do
  let d :: ParsecT Void Text Identity (Token Text)
d = [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)
oneOf [Char
'0' .. Char
'9']
  String
beforeDot <- 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
ParsecT Void Text Identity (Token Text)
d :: Parser String
  Maybe String
afterDot <-
    ParsecT Void Text Identity String
-> ParsecT Void Text Identity (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ParsecT Void Text Identity String
 -> ParsecT Void Text Identity (Maybe String))
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
      Char
dot <- 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
'.'
      String
r <- 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
ParsecT Void Text Identity (Token Text)
d
      String -> ParsecT Void Text Identity String
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> ParsecT Void Text Identity String)
-> String -> ParsecT Void Text Identity String
forall a b. (a -> b) -> a -> b
$ Char
dot Char -> String -> String
forall a. a -> [a] -> [a]
: String
r
  Pico -> Parser Pico
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pico -> Parser Pico) -> Pico -> Parser Pico
forall a b. (a -> b) -> a -> b
$ String -> Pico
forall a. Read a => String -> a
read (String -> Pico) -> String -> Pico
forall a b. (a -> b) -> a -> b
$ String
beforeDot String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
afterDot

diffP :: Parser FuzzyTimeOfDay
diffP :: Parser FuzzyTimeOfDay
diffP =
  String -> Parser FuzzyTimeOfDay -> Parser FuzzyTimeOfDay
forall a.
String
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"Diff" (Parser FuzzyTimeOfDay -> Parser FuzzyTimeOfDay)
-> Parser FuzzyTimeOfDay -> Parser FuzzyTimeOfDay
forall a b. (a -> b) -> a -> b
$ do
    Int
n <- Parser Int -> Parser Int
forall a. Num a => Parser a -> Parser a
signed' Parser Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal
    Maybe Char
mc <- ParsecT Void Text Identity Char
-> ParsecT Void Text Identity (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ParsecT Void Text Identity Char
 -> ParsecT Void Text Identity (Maybe Char))
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity (Maybe Char)
forall a b. (a -> b) -> a -> b
$ [ParsecT Void Text Identity Char]
-> ParsecT Void Text Identity Char
forall a. [Parser a] -> Parser a
choice' [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
'h', 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', 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
's']
    Int -> FuzzyTimeOfDay
f <-
      case Maybe Char
mc of
        Maybe Char
Nothing -> (Int -> FuzzyTimeOfDay)
-> ParsecT Void Text Identity (Int -> FuzzyTimeOfDay)
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int -> FuzzyTimeOfDay
HoursDiff
        Just Char
'h' -> (Int -> FuzzyTimeOfDay)
-> ParsecT Void Text Identity (Int -> FuzzyTimeOfDay)
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int -> FuzzyTimeOfDay
HoursDiff
        Just Char
'm' -> (Int -> FuzzyTimeOfDay)
-> ParsecT Void Text Identity (Int -> FuzzyTimeOfDay)
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int -> FuzzyTimeOfDay
MinutesDiff
        Just Char
's' -> (Int -> FuzzyTimeOfDay)
-> ParsecT Void Text Identity (Int -> FuzzyTimeOfDay)
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\Int
i -> Pico -> FuzzyTimeOfDay
SecondsDiff (Pico -> FuzzyTimeOfDay) -> Pico -> FuzzyTimeOfDay
forall a b. (a -> b) -> a -> b
$ Int -> Pico
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)
        Maybe Char
_ -> String -> ParsecT Void Text Identity (Int -> FuzzyTimeOfDay)
forall a. String -> ParsecT Void Text Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"should not happen."
    FuzzyTimeOfDay -> Parser FuzzyTimeOfDay
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FuzzyTimeOfDay -> Parser FuzzyTimeOfDay)
-> FuzzyTimeOfDay -> Parser FuzzyTimeOfDay
forall a b. (a -> b) -> a -> b
$ Int -> FuzzyTimeOfDay
f Int
n

hourSegmentP :: Parser Int
hourSegmentP :: Parser Int
hourSegmentP =
  String -> Parser Int -> Parser Int
forall a.
String
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"hour segment" (Parser Int -> Parser Int) -> Parser Int -> Parser Int
forall a b. (a -> b) -> a -> b
$ do
    Int
h <- Parser Int
forall a. (Num a, Read a) => Parser a
twoDigitsSegmentP
    Bool -> ParsecT Void Text Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ParsecT Void Text Identity ())
-> Bool -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ Int
h Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
h Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
24
    ParsecT Void Text Identity (Maybe Char)
-> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity (Maybe Char)
 -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity (Maybe Char)
-> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity Char
-> ParsecT Void Text Identity (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ParsecT Void Text Identity Char
 -> ParsecT Void Text Identity (Maybe Char))
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity (Maybe Char)
forall a b. (a -> b) -> a -> b
$ 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
':'
    Int -> Parser Int
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
h

minuteSegmentP :: Parser Int
minuteSegmentP :: Parser Int
minuteSegmentP =
  String -> Parser Int -> Parser Int
forall a.
String
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"minute segment" (Parser Int -> Parser Int) -> Parser Int -> Parser Int
forall a b. (a -> b) -> a -> b
$ do
    Int
m <- Parser Int
forall a. (Num a, Read a) => Parser a
twoDigitsSegmentP
    Bool -> ParsecT Void Text Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ParsecT Void Text Identity ())
-> Bool -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
60
    Int -> Parser Int
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
m

twoDigitsSegmentP :: (Num a, Read a) => Parser a
twoDigitsSegmentP :: forall a. (Num a, Read a) => Parser a
twoDigitsSegmentP =
  String
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall a.
String
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"two digit segment" (ParsecT Void Text Identity a -> ParsecT Void Text Identity a)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall a b. (a -> b) -> a -> b
$ do
    a
d1 <- ParsecT Void Text Identity a
forall a. Read a => Parser a
digit
    Maybe a
md2 <- ParsecT Void Text Identity a
-> ParsecT Void Text Identity (Maybe a)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT Void Text Identity a
forall a. Read a => Parser a
digit
    a -> ParsecT Void Text Identity a
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> ParsecT Void Text Identity a)
-> a -> ParsecT Void Text Identity a
forall a b. (a -> b) -> a -> b
$
      case Maybe a
md2 of
        Maybe a
Nothing -> a
d1
        Just a
d2 -> a
10 a -> a -> a
forall a. Num a => a -> a -> a
* a
d1 a -> a -> a
forall a. Num a => a -> a -> a
+ a
d2

digit :: (Read a) => Parser a
digit :: forall a. Read a => Parser a
digit =
  String
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall a.
String
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"digit" (ParsecT Void Text Identity a -> ParsecT Void Text Identity a)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall a b. (a -> b) -> a -> b
$ do
    let l :: String
l = [Char
'0' .. Char
'9']
    Char
c <- [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)
oneOf String
[Token Text]
l
    case String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe [Char
c] of
      Maybe a
Nothing -> String -> ParsecT Void Text Identity a
forall a. String -> ParsecT Void Text Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Shouldn't happen."
      Just a
d -> a -> ParsecT Void Text Identity a
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
d

-- | Can handle:
--
-- - yesterday
-- - now
-- - today
-- - tomorrow
-- - "%Y-%m-%d"
--
-- and all non-ambiguous prefixes
fuzzyDayP :: Parser FuzzyDay
fuzzyDayP :: Parser FuzzyDay
fuzzyDayP =
  String -> Parser FuzzyDay -> Parser FuzzyDay
forall a.
String
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"FuzzyDay" (Parser FuzzyDay -> Parser FuzzyDay)
-> Parser FuzzyDay -> Parser FuzzyDay
forall a b. (a -> b) -> a -> b
$
    [Parser FuzzyDay] -> Parser FuzzyDay
forall a. [Parser a] -> Parser a
choice'
      [ [(String, FuzzyDay)] -> Parser FuzzyDay
forall a. [(String, a)] -> Parser a
recTreeParser
          [(String
"yesterday", FuzzyDay
Yesterday), (String
"now", FuzzyDay
Now), (String
"today", FuzzyDay
Today), (String
"tomorrow", FuzzyDay
Tomorrow)],
        (Day -> FuzzyDay)
-> ParsecT Void Text Identity Day -> Parser FuzzyDay
forall a b.
(a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Day -> FuzzyDay
ExactDay (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
ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
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 String
-> (String -> ParsecT Void Text Identity Day)
-> ParsecT Void Text Identity Day
forall a b.
ParsecT Void Text Identity a
-> (a -> ParsecT Void Text Identity b)
-> ParsecT Void Text Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool
-> TimeLocale -> String -> String -> ParsecT Void Text Identity Day
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
"%Y-%m-%d"),
        Parser FuzzyDay
dayInMonthP,
        Parser FuzzyDay
dayOfTheMonthP,
        Parser FuzzyDay
fuzzyDayOfTheWeekP,
        Parser FuzzyDay
diffDayP
      ]

dayOfTheMonthP :: Parser FuzzyDay
dayOfTheMonthP :: Parser FuzzyDay
dayOfTheMonthP = do
  Word8
dayNo <- Parser Word8
forall a. (Num a, Read a) => Parser a
twoDigitsSegmentP
  let v :: FuzzyDay
v = Word8 -> FuzzyDay
OnlyDay Word8
dayNo
  Bool -> ParsecT Void Text Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ParsecT Void Text Identity ())
-> Bool -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ FuzzyDay -> Bool
forall a. Validity a => a -> Bool
isValid FuzzyDay
v
  FuzzyDay -> Parser FuzzyDay
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FuzzyDay
v

dayInMonthP :: Parser FuzzyDay
dayInMonthP :: Parser FuzzyDay
dayInMonthP = do
  Word8
m <-
    [Parser Word8] -> Parser Word8
forall a. [Parser a] -> Parser a
choice'
      [ do
          Word8
m <- Parser Word8
forall a. (Num a, Read a) => Parser a
twoDigitsSegmentP
          Bool -> ParsecT Void Text Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Word8
m Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
1)
          Bool -> ParsecT Void Text Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Word8
m Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
12)
          Word8 -> Parser Word8
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word8
m,
        Parser Word8
namedMonthP
      ]
  ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity (Tokens Text)
 -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"-"
  Word8
d <- Parser Word8
forall a. (Num a, Read a) => Parser a
twoDigitsSegmentP
  let v :: FuzzyDay
v = Word8 -> Word8 -> FuzzyDay
DayInMonth Word8
m Word8
d
  Bool -> ParsecT Void Text Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ParsecT Void Text Identity ())
-> Bool -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ FuzzyDay -> Bool
forall a. Validity a => a -> Bool
isValid FuzzyDay
v
  FuzzyDay -> Parser FuzzyDay
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FuzzyDay
v

namedMonthP :: Parser Word8
namedMonthP :: Parser Word8
namedMonthP =
  [(String, Word8)] -> Parser Word8
forall a. [(String, a)] -> Parser a
recTreeParser
    [ (String
"january", Word8
1),
      (String
"february", Word8
2),
      (String
"march", Word8
3),
      (String
"april", Word8
4),
      (String
"may", Word8
5),
      (String
"june", Word8
6),
      (String
"july", Word8
7),
      (String
"august", Word8
8),
      (String
"september", Word8
9),
      (String
"october", Word8
10),
      (String
"november", Word8
11),
      (String
"december", Word8
12)
    ]

diffDayP :: Parser FuzzyDay
diffDayP :: Parser FuzzyDay
diffDayP = do
  Int16
d <- Parser Int16 -> Parser Int16
forall a. Num a => Parser a -> Parser a
signed' Parser Int16
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal
  Maybe Char
mc <- ParsecT Void Text Identity Char
-> ParsecT Void Text Identity (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ParsecT Void Text Identity Char
 -> ParsecT Void Text Identity (Maybe Char))
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity (Maybe Char)
forall a b. (a -> b) -> a -> b
$ [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)
oneOf [Char
'd', Char
'w', Char
'm']
  let f :: Int16 -> FuzzyDay
f =
        case Maybe Char
mc of
          Maybe Char
Nothing -> Int16 -> FuzzyDay
DiffDays
          Just Char
'd' -> Int16 -> FuzzyDay
DiffDays
          Just Char
'w' -> Int16 -> FuzzyDay
DiffWeeks
          Just Char
'm' -> Int16 -> FuzzyDay
DiffMonths
          Maybe Char
_ -> Int16 -> FuzzyDay
DiffDays -- Should not happen.
  FuzzyDay -> Parser FuzzyDay
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FuzzyDay -> Parser FuzzyDay) -> FuzzyDay -> Parser FuzzyDay
forall a b. (a -> b) -> a -> b
$ Int16 -> FuzzyDay
f Int16
d

fuzzyDayOfTheWeekP :: Parser FuzzyDay
fuzzyDayOfTheWeekP :: Parser FuzzyDay
fuzzyDayOfTheWeekP = do
  DayOfWeek
dow <- Parser DayOfWeek
dayOfTheWeekP
  Maybe Int16
mExtraDiff <- Parser Int16 -> ParsecT Void Text Identity (Maybe Int16)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser Int16 -> ParsecT Void Text Identity (Maybe Int16))
-> Parser Int16 -> ParsecT Void Text Identity (Maybe Int16)
forall a b. (a -> b) -> a -> b
$ Parser Int16 -> Parser Int16
forall a. Num a => Parser a -> Parser a
signed' Parser Int16
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal
  FuzzyDay -> Parser FuzzyDay
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FuzzyDay -> Parser FuzzyDay) -> FuzzyDay -> Parser FuzzyDay
forall a b. (a -> b) -> a -> b
$ DayOfWeek -> Int16 -> FuzzyDay
DayOfTheWeek DayOfWeek
dow (Int16 -> Maybe Int16 -> Int16
forall a. a -> Maybe a -> a
fromMaybe Int16
0 Maybe Int16
mExtraDiff)

-- | Can handle:
--
-- - monday
-- - tuesday
-- - wednesday
-- - thursday
-- - friday
-- - saturday
-- - sunday
--
-- and all non-ambiguous prefixes
dayOfTheWeekP :: Parser DayOfWeek
dayOfTheWeekP :: Parser DayOfWeek
dayOfTheWeekP =
  [(String, DayOfWeek)] -> Parser DayOfWeek
forall a. [(String, a)] -> Parser a
recTreeParser
    [ (String
"monday", DayOfWeek
Monday),
      (String
"tuesday", DayOfWeek
Tuesday),
      (String
"wednesday", DayOfWeek
Wednesday),
      (String
"thursday", DayOfWeek
Thursday),
      (String
"friday", DayOfWeek
Friday),
      (String
"saturday", DayOfWeek
Saturday),
      (String
"sunday", DayOfWeek
Sunday)
    ]

recTreeParser :: [(String, a)] -> Parser a
recTreeParser :: forall a. [(String, a)] -> Parser a
recTreeParser [(String, a)]
tups = do
  let pf :: Forest (Char, Maybe a)
pf = [(String, a)] -> Forest (Char, Maybe a)
forall c a. Eq c => [([c], a)] -> Forest (c, Maybe a)
makeParseForest [(String, a)]
tups
  String
s <- 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
ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
letterChar
  case String -> Forest (Char, Maybe a) -> Maybe a
forall a. String -> Forest (Char, Maybe a) -> Maybe a
lookupInParseForest String
s Forest (Char, Maybe a)
pf of
    Maybe a
Nothing ->
      String -> Parser a
forall a. String -> ParsecT Void Text Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser a) -> String -> Parser a
forall a b. (a -> b) -> a -> b
$ String
"Could not parse any of these recursively unambiguously: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show (((String, a) -> String) -> [(String, a)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, a) -> String
forall a b. (a, b) -> a
fst [(String, a)]
tups)
    Just a
f -> a -> Parser a
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
f

lookupInParseForest :: [Char] -> Forest (Char, Maybe a) -> Maybe a
lookupInParseForest :: forall a. String -> Forest (Char, Maybe a) -> Maybe a
lookupInParseForest = String -> Forest (Char, Maybe a) -> Maybe a
forall a. String -> Forest (Char, Maybe a) -> Maybe a
gof
  where
    gof :: [Char] -> Forest (Char, Maybe a) -> Maybe a
    gof :: forall a. String -> Forest (Char, Maybe a) -> Maybe a
gof String
cs = [Maybe a] -> Maybe a
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Maybe a] -> Maybe a)
-> (Forest (Char, Maybe a) -> [Maybe a])
-> Forest (Char, Maybe a)
-> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tree (Char, Maybe a) -> Maybe a)
-> Forest (Char, Maybe a) -> [Maybe a]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Tree (Char, Maybe a) -> Maybe a
forall a. String -> Tree (Char, Maybe a) -> Maybe a
got String
cs)
    got :: [Char] -> Tree (Char, Maybe a) -> Maybe a
    got :: forall a. String -> Tree (Char, Maybe a) -> Maybe a
got [] Tree (Char, Maybe a)
_ = Maybe a
forall a. Maybe a
Nothing
    got (Char
c : String
cs) Node {[Tree (Char, Maybe a)]
(Char, Maybe a)
rootLabel :: forall a. Tree a -> a
subForest :: forall a. Tree a -> [Tree a]
rootLabel :: (Char, Maybe a)
subForest :: [Tree (Char, Maybe a)]
..} =
      let (Char
tc, Maybe a
tma) = (Char, Maybe a)
rootLabel
       in if Char -> Char
Char.toLower Char
tc Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Char
Char.toLower Char
c
            then case String
cs of
              [] -> Maybe a
tma
              String
_ -> String -> [Tree (Char, Maybe a)] -> Maybe a
forall a. String -> Forest (Char, Maybe a) -> Maybe a
gof String
cs [Tree (Char, Maybe a)]
subForest
            else Maybe a
forall a. Maybe a
Nothing

makeParseForest :: (Eq c) => [([c], a)] -> Forest (c, Maybe a)
makeParseForest :: forall c a. Eq c => [([c], a)] -> Forest (c, Maybe a)
makeParseForest = (Forest (c, Maybe a) -> ([c], a) -> Forest (c, Maybe a))
-> Forest (c, Maybe a) -> [([c], a)] -> Forest (c, Maybe a)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Forest (c, Maybe a) -> ([c], a) -> Forest (c, Maybe a)
forall c a.
Eq c =>
Forest (c, Maybe a) -> ([c], a) -> Forest (c, Maybe a)
insertf []
  where
    insertf :: (Eq c) => Forest (c, Maybe a) -> ([c], a) -> Forest (c, Maybe a)
    insertf :: forall c a.
Eq c =>
Forest (c, Maybe a) -> ([c], a) -> Forest (c, Maybe a)
insertf Forest (c, Maybe a)
for ([], a
_) = Forest (c, Maybe a)
for
    insertf Forest (c, Maybe a)
for (c
c : [c]
cs, a
a) =
      case (Tree (c, Maybe a) -> Bool)
-> Forest (c, Maybe a) -> Maybe (Tree (c, Maybe a))
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((c -> c -> Bool
forall a. Eq a => a -> a -> Bool
== c
c) (c -> Bool)
-> (Tree (c, Maybe a) -> c) -> Tree (c, Maybe a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c, Maybe a) -> c
forall a b. (a, b) -> a
fst ((c, Maybe a) -> c)
-> (Tree (c, Maybe a) -> (c, Maybe a)) -> Tree (c, Maybe a) -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree (c, Maybe a) -> (c, Maybe a)
forall a. Tree a -> a
rootLabel) Forest (c, Maybe a)
for of
        Maybe (Tree (c, Maybe a))
Nothing ->
          let got :: [c] -> Maybe (Tree (c, Maybe a))
got [] = Maybe (Tree (c, Maybe a))
forall a. Maybe a
Nothing
              got (c
c_ : [c]
cs_) = Tree (c, Maybe a) -> Maybe (Tree (c, Maybe a))
forall a. a -> Maybe a
Just (Tree (c, Maybe a) -> Maybe (Tree (c, Maybe a)))
-> Tree (c, Maybe a) -> Maybe (Tree (c, Maybe a))
forall a b. (a -> b) -> a -> b
$ (c, Maybe a) -> Forest (c, Maybe a) -> Tree (c, Maybe a)
forall a. a -> [Tree a] -> Tree a
Node (c
c_, a -> Maybe a
forall a. a -> Maybe a
Just a
a) (Forest (c, Maybe a) -> Tree (c, Maybe a))
-> Forest (c, Maybe a) -> Tree (c, Maybe a)
forall a b. (a -> b) -> a -> b
$ Maybe (Tree (c, Maybe a)) -> Forest (c, Maybe a)
forall a. Maybe a -> [a]
maybeToList (Maybe (Tree (c, Maybe a)) -> Forest (c, Maybe a))
-> Maybe (Tree (c, Maybe a)) -> Forest (c, Maybe a)
forall a b. (a -> b) -> a -> b
$ [c] -> Maybe (Tree (c, Maybe a))
got [c]
cs_
           in case [c] -> Maybe (Tree (c, Maybe a))
got (c
c c -> [c] -> [c]
forall a. a -> [a] -> [a]
: [c]
cs) of
                Maybe (Tree (c, Maybe a))
Nothing -> Forest (c, Maybe a)
for -- Should not happen, but is fine
                Just Tree (c, Maybe a)
t -> Tree (c, Maybe a)
t Tree (c, Maybe a) -> Forest (c, Maybe a) -> Forest (c, Maybe a)
forall a. a -> [a] -> [a]
: Forest (c, Maybe a)
for
        Just Tree (c, Maybe a)
n ->
          ((Tree (c, Maybe a) -> Tree (c, Maybe a))
 -> Forest (c, Maybe a) -> Forest (c, Maybe a))
-> Forest (c, Maybe a)
-> (Tree (c, Maybe a) -> Tree (c, Maybe a))
-> Forest (c, Maybe a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Tree (c, Maybe a) -> Tree (c, Maybe a))
-> Forest (c, Maybe a) -> Forest (c, Maybe a)
forall a b. (a -> b) -> [a] -> [b]
map Forest (c, Maybe a)
for ((Tree (c, Maybe a) -> Tree (c, Maybe a)) -> Forest (c, Maybe a))
-> (Tree (c, Maybe a) -> Tree (c, Maybe a)) -> Forest (c, Maybe a)
forall a b. (a -> b) -> a -> b
$ \Tree (c, Maybe a)
t ->
            let (c
tc, Maybe a
_) = Tree (c, Maybe a) -> (c, Maybe a)
forall a. Tree a -> a
rootLabel Tree (c, Maybe a)
t
             in if c
tc c -> c -> Bool
forall a. Eq a => a -> a -> Bool
== c
c
                  then Tree (c, Maybe a)
n {rootLabel = (tc, Nothing), subForest = insertf (subForest n) (cs, a)}
                  else Tree (c, Maybe a)
t

signed' :: (Num a) => Parser a -> Parser a
signed' :: forall a. Num a => Parser a -> Parser a
signed' Parser a
p = ParsecT Void Text Identity (a -> a)
sign ParsecT Void Text Identity (a -> a) -> Parser a -> Parser a
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser a
p
  where
    sign :: ParsecT Void Text Identity (a -> a)
sign = (a -> a
forall a. a -> a
id (a -> a)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity (a -> a)
forall a b.
a -> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> 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 (a -> a)
-> ParsecT Void Text Identity (a -> a)
-> ParsecT Void Text Identity (a -> a)
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (a -> a
forall a. Num a => a -> a
negate (a -> a)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity (a -> a)
forall a b.
a -> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> 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
'-')

choice' :: [Parser a] -> Parser a
choice' :: forall a. [Parser a] -> Parser a
choice' [] = Parser a
forall a. ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a
empty
choice' [Parser a
x] = Parser a
x
choice' (Parser a
a : [Parser a]
as) = Parser a -> Parser a
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parser a
a Parser a -> Parser a -> Parser a
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Parser a] -> Parser a
forall a. [Parser a] -> Parser a
choice' [Parser a]
as

choice'' :: [Parser a] -> Parser a
choice'' :: forall a. [Parser a] -> Parser a
choice'' = [Parser a] -> Parser a
forall a. [Parser a] -> Parser a
choice' ([Parser a] -> Parser a)
-> ([Parser a] -> [Parser a]) -> [Parser a] -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Parser a -> Parser a) -> [Parser a] -> [Parser a]
forall a b. (a -> b) -> [a] -> [b]
map (Parser a -> ParsecT Void Text Identity () -> Parser a
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
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)