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

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

import Control.Monad
import Data.Char as Char
import Data.Fixed
import Data.FuzzyTime.Types
import Data.List
import Data.Maybe
import Data.Text (Text)
import Data.Time
import Data.Tree
import Data.Validity
import Data.Void
import Text.Megaparsec
import Text.Megaparsec.Char as Char
import Text.Megaparsec.Char.Lexer as Lexer

type Parser = Parsec Void Text

fuzzyZonedTimeP :: Parser FuzzyZonedTime
fuzzyZonedTimeP :: Parser FuzzyZonedTime
fuzzyZonedTimeP = FuzzyZonedTime -> Parser FuzzyZonedTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure FuzzyZonedTime
ZonedNow

fuzzyLocalTimeP :: Parser FuzzyLocalTime
fuzzyLocalTimeP :: Parser FuzzyLocalTime
fuzzyLocalTimeP = String -> Parser FuzzyLocalTime -> Parser FuzzyLocalTime
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
$ Some FuzzyDay FuzzyTimeOfDay -> FuzzyLocalTime
FuzzyLocalTime (Some FuzzyDay FuzzyTimeOfDay -> FuzzyLocalTime)
-> ParsecT Void Text Identity (Some FuzzyDay FuzzyTimeOfDay)
-> Parser FuzzyLocalTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser FuzzyDay
-> Parser FuzzyTimeOfDay
-> ParsecT Void Text Identity (Some FuzzyDay FuzzyTimeOfDay)
forall a b. Parser a -> Parser b -> Parser (Some a b)
parseSome Parser FuzzyDay
fuzzyDayP Parser FuzzyTimeOfDay
fuzzyTimeOfDayP

-- | Note: Not composable
parseSome :: Parser a -> Parser b -> Parser (Some a b)
parseSome :: Parser a -> Parser b -> Parser (Some a b)
parseSome Parser a
pa Parser b
pb =
  String -> Parser (Some a b) -> Parser (Some a b)
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"Some" (Parser (Some a b) -> Parser (Some a b))
-> Parser (Some a b) -> Parser (Some a b)
forall a b. (a -> b) -> a -> b
$
    [Parser (Some a b)] -> Parser (Some a b)
forall a. [Parser a] -> Parser a
choice''
      [ do
          a
a <- Parser a
pa
          ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space1
          b
b <- Parser b
pb
          Some a b -> Parser (Some a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Some a b -> Parser (Some a b)) -> Some a b -> Parser (Some a b)
forall a b. (a -> b) -> a -> b
$ a -> b -> Some a b
forall a b. a -> b -> Some a b
Both a
a b
b,
        a -> Some a b
forall a b. a -> Some a b
One (a -> Some a b) -> Parser a -> Parser (Some a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a
pa,
        b -> Some a b
forall a b. b -> Some a b
Other (b -> Some a b) -> Parser b -> Parser (Some a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser b
pb
      ]

fuzzyTimeOfDayP :: Parser FuzzyTimeOfDay
fuzzyTimeOfDayP :: Parser FuzzyTimeOfDay
fuzzyTimeOfDayP =
  String -> Parser FuzzyTimeOfDay -> Parser FuzzyTimeOfDay
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 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 (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 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 (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 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 (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 (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 (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 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 (f :: * -> *) a. Applicative f => a -> f a
pure Int -> FuzzyTimeOfDay
HoursDiff
        Just Char
'h' -> (Int -> FuzzyTimeOfDay)
-> ParsecT Void Text Identity (Int -> FuzzyTimeOfDay)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int -> FuzzyTimeOfDay
HoursDiff
        Just Char
'm' -> (Int -> FuzzyTimeOfDay)
-> ParsecT Void Text Identity (Int -> FuzzyTimeOfDay)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int -> FuzzyTimeOfDay
MinutesDiff
        Just Char
's' -> (Int -> FuzzyTimeOfDay)
-> ParsecT Void Text Identity (Int -> FuzzyTimeOfDay)
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 (m :: * -> *) a. MonadFail m => String -> m a
fail String
"should not happen."
    FuzzyTimeOfDay -> Parser FuzzyTimeOfDay
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 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
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 (f :: * -> *) a. Applicative f => a -> f a
pure Int
h

minuteSegmentP :: Parser Int
minuteSegmentP :: Parser Int
minuteSegmentP =
  String -> Parser Int -> Parser Int
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
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 (f :: * -> *) a. Applicative f => a -> f a
pure Int
m

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

digit :: Parser Int
digit :: Parser Int
digit =
  String -> Parser Int -> Parser Int
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"digit" (Parser Int -> Parser Int) -> Parser Int -> Parser Int
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 Char -> String -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Char
c String
l of
      Maybe Int
Nothing -> String -> Parser Int
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Shouldn't happen."
      Just Int
d -> Int -> Parser Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
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 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 (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
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 (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 (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,
        DayOfWeek -> FuzzyDay
NextDayOfTheWeek (DayOfWeek -> FuzzyDay)
-> ParsecT Void Text Identity DayOfWeek -> Parser FuzzyDay
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity DayOfWeek
fuzzyDayOfTheWeekP,
        Parser FuzzyDay
diffDayP
      ]

dayOfTheMonthP :: Parser FuzzyDay
dayOfTheMonthP :: Parser FuzzyDay
dayOfTheMonthP = do
  FuzzyDay
v <- Int -> FuzzyDay
OnlyDay (Int -> FuzzyDay) -> Parser Int -> Parser FuzzyDay
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Int
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
$ FuzzyDay -> Bool
forall a. Validity a => a -> Bool
isValid FuzzyDay
v
  FuzzyDay -> Parser FuzzyDay
forall (f :: * -> *) a. Applicative f => a -> f a
pure FuzzyDay
v

dayInMonthP :: Parser FuzzyDay
dayInMonthP :: Parser FuzzyDay
dayInMonthP = do
  Int
m <- Parser Int
twoDigitsSegmentP
  Bool -> ParsecT Void Text Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1)
  Bool -> ParsecT Void Text Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
12)
  ParsecT Void Text Identity Text -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Text -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity 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
"-"
  Int
d <- Parser Int
twoDigitsSegmentP
  let v :: FuzzyDay
v = Int -> Int -> FuzzyDay
DayInMonth Int
m Int
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 (f :: * -> *) a. Applicative f => a -> f a
pure FuzzyDay
v

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 (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

-- | Can handle:
--
-- - monday
-- - tuesday
-- - wednesday
-- - thursday
-- - friday
-- - saturday
-- - sunday
--
-- and all non-ambiguous prefixes
fuzzyDayOfTheWeekP :: Parser DayOfWeek
fuzzyDayOfTheWeekP :: ParsecT Void Text Identity DayOfWeek
fuzzyDayOfTheWeekP =
  [(String, DayOfWeek)] -> ParsecT Void Text Identity 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 :: [(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
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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure a
f

lookupInParseForest :: [Char] -> Forest (Char, Maybe a) -> Maybe a
lookupInParseForest :: 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 :: 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 :: 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 {Forest (Char, Maybe a)
(Char, Maybe a)
rootLabel :: forall a. Tree a -> a
subForest :: forall a. Tree a -> Forest a
subForest :: Forest (Char, Maybe a)
rootLabel :: (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 -> Forest (Char, Maybe a) -> Maybe a
forall a. String -> Forest (Char, Maybe a) -> Maybe a
gof String
cs Forest (Char, Maybe a)
subForest
            else Maybe a
forall a. Maybe a
Nothing

makeParseForest :: Eq c => [([c], a)] -> Forest (c, Maybe a)
makeParseForest :: [([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 (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 :: 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 -> Forest 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 :: (c, Maybe a)
rootLabel = (c
tc, Maybe a
forall a. Maybe a
Nothing), subForest :: Forest (c, Maybe a)
subForest = 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 (Tree (c, Maybe a) -> Forest (c, Maybe a)
forall a. Tree a -> Forest a
subForest Tree (c, Maybe a)
n) ([c]
cs, a
a)}
                  else Tree (c, Maybe a)
t

signed' :: Num a => Parser a -> Parser a
signed' :: 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 (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 (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 (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 (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' :: [Parser a] -> Parser a
choice' [] = Parser 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 e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parser a
a Parser a -> Parser a -> Parser 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'' :: [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 (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)