{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GADTs #-}
module Data.HodaTime.Pattern.CalendarDate
(
  -- * Standard Patterns
   pd
  ,pD
  -- * Custom Patterns
  --
  -- | Used to create specialized patterns.
  ,pyyyy
  ,pMM
  ,pMMMM
  ,pdd
)
where

import Data.HodaTime.Pattern.Internal
import Data.HodaTime.CalendarDateTime.Internal (HasDate, Month, IsCalendar, monthl)
import qualified Data.HodaTime.CalendarDateTime.Internal as CDT (day, year)
import qualified  Data.Text as T
import qualified  Data.Text.Lazy.Builder as TLB
import Data.Char(toLower, toUpper)
import Control.Applicative ((<|>))
import Text.Parsec (digit, count, choice, oneOf, try)
import qualified Text.Parsec as P (char)
import Formatting (left, (%.), later)

-- d1 = maybe (error "duh") id $ calendarDate 1 January 2000
-- d2 = maybe (error "duh") id $ calendarDate 3 March 2020
-- format Data.HodaTime.Pattern.CalendarDate.date d1
-- format Data.HodaTime.Pattern.CalendarDate.date d2
-- parse Data.HodaTime.Pattern.CalendarDate.date "2000/March/01" :: IO (CalendarDate Gregorian)

-- | Absolute year in exactly 4 digits; values 0000-9999 (note: not all dates will be valid in all calendars, if the date is too early it will clamp to earliest valid date)
pyyyy :: HasDate d => Pattern (d -> d) (d -> String) String
pyyyy :: forall d. HasDate d => Pattern (d -> d) (d -> String) String
pyyyy = Lens d d Year Year
-> Parser Year String
-> ((d -> Year) -> Format String (d -> String))
-> String
-> Pattern (d -> d) (d -> String) String
forall s a.
Lens s s a a
-> Parser a String
-> ((s -> a) -> Format String (s -> String))
-> String
-> Pattern (s -> s) (s -> String) String
pat_lens (Year -> f Year) -> d -> f d
forall d (f :: * -> *).
(HasDate d, Functor f) =>
(Year -> f Year) -> d -> f d
Lens d d Year Year
CDT.year Parser Year String
forall {u}. ParsecT String u Identity Year
p (d -> Year) -> Format String (d -> String)
forall {b} {a} {r'}. Show b => (a -> b) -> Format r' (a -> r')
fmt String
"year: 0000-9999"
  where
    p :: ParsecT String u Identity Year
p = String -> Year
forall a. Read a => String -> a
read (String -> Year)
-> ParsecT String u Identity String
-> ParsecT String u Identity Year
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Year
-> ParsecT String u Identity Char
-> ParsecT String u Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
Year -> ParsecT s u m a -> ParsecT s u m [a]
count Year
4 ParsecT String u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
    fmt :: (a -> b) -> Format r' (a -> r')
fmt a -> b
x = Year -> Char -> Format r' (Builder -> r')
forall a r. Buildable a => Year -> Char -> Format r (a -> r)
left Year
4 Char
'0' Format r' (Builder -> r')
-> Format r' (a -> r') -> Format r' (a -> r')
forall r r' a.
Format r (Builder -> r') -> Format r' a -> Format r a
%. (a -> b) -> Format r' (a -> r')
forall {b} {a} {r'}. Show b => (a -> b) -> Format r' (a -> r')
f_shown a -> b
x

-- | Month of year specified as a number - zero-padded
pMM :: HasDate d => Pattern (d -> d) (d -> String) String
pMM :: forall d. HasDate d => Pattern (d -> d) (d -> String) String
pMM = Lens d d Year Year
-> Parser Year String
-> ((d -> Year) -> Format String (d -> String))
-> String
-> Pattern (d -> d) (d -> String) String
forall s a.
Lens s s a a
-> Parser a String
-> ((s -> a) -> Format String (s -> String))
-> String
-> Pattern (s -> s) (s -> String) String
pat_lens (Year -> f Year) -> d -> f d
forall d (f :: * -> *).
(HasDate d, Functor f) =>
(Year -> f Year) -> d -> f d
Lens d d Year Year
monthl Parser Year String
p (d -> Year) -> Format String (d -> String)
forall {b} {a} {r'}.
(Show b, Enum b) =>
(a -> b) -> Format r' (a -> r')
fmt String
"month: 01-12"
  where
    p :: Parser Year String
p = Year -> Year
forall a. Enum a => a -> a
pred (Year -> Year) -> Parser Year String -> Parser Year String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser Year String
forall {u}. ParsecT String u Identity Year
p_a Parser Year String -> Parser Year String -> Parser Year String
forall a.
ParsecT String () Identity a
-> ParsecT String () Identity a -> ParsecT String () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Year String
forall {u}. ParsecT String u Identity Year
p_b)
    p_a :: ParsecT String u Identity Year
p_a = Char -> Char -> Year
forall n. (Num n, Read n) => Char -> Char -> n
digitsToInt (Char -> Char -> Year)
-> ParsecT String u Identity Char
-> ParsecT String u Identity (Char -> Year)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'0' ParsecT String u Identity (Char -> Year)
-> ParsecT String u Identity Char -> ParsecT String u Identity Year
forall a b.
ParsecT String u Identity (a -> b)
-> ParsecT String u Identity a -> ParsecT String u Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT String u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
    p_b :: ParsecT String u Identity Year
p_b = Char -> Char -> Year
forall n. (Num n, Read n) => Char -> Char -> n
digitsToInt (Char -> Char -> Year)
-> ParsecT String u Identity Char
-> ParsecT String u Identity (Char -> Year)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'1' ParsecT String u Identity (Char -> Year)
-> ParsecT String u Identity Char -> ParsecT String u Identity Year
forall a b.
ParsecT String u Identity (a -> b)
-> ParsecT String u Identity a -> ParsecT String u Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf [Char
'0'..Char
'2']
    fmt :: (a -> b) -> Format r' (a -> r')
fmt a -> b
x = Year -> Char -> Format r' (Builder -> r')
forall a r. Buildable a => Year -> Char -> Format r (a -> r)
left Year
2 Char
'0' Format r' (Builder -> r')
-> Format r' (a -> r') -> Format r' (a -> r')
forall r r' a.
Format r (Builder -> r') -> Format r' a -> Format r a
%. (a -> Builder) -> Format r' (a -> r')
forall a r. (a -> Builder) -> Format r (a -> r)
later (Text -> Builder
TLB.fromText (Text -> Builder) -> (a -> Text) -> a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> String
forall a. Show a => a -> String
show (b -> String) -> (a -> b) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> b
forall a. Enum a => a -> a
succ (b -> b) -> (a -> b) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
x)

-- | Full month name, parsed case-insensitively.  Formats in title case
pMMMM :: forall cal d c. (d ~ c cal, IsCalendar cal, HasDate d, Bounded (Month cal), Read (Month cal), Show (Month cal), Enum (Month cal)) => Pattern (d -> d) (d -> String) String
pMMMM :: forall cal d (c :: * -> *).
(d ~ c cal, IsCalendar cal, HasDate d, Bounded (Month cal),
 Read (Month cal), Show (Month cal), Enum (Month cal)) =>
Pattern (d -> d) (d -> String) String
pMMMM = Lens d d Year Year
-> Parser Year String
-> ((d -> Year) -> Format String (d -> String))
-> String
-> Pattern (d -> d) (d -> String) String
forall s a.
Lens s s a a
-> Parser a String
-> ((s -> a) -> Format String (s -> String))
-> String
-> Pattern (s -> s) (s -> String) String
pat_lens (Year -> f Year) -> d -> f d
forall d (f :: * -> *).
(HasDate d, Functor f) =>
(Year -> f Year) -> d -> f d
Lens d d Year Year
monthl Parser Year String
p' (d -> Year) -> Format String (d -> String)
fmt' (String -> Pattern (d -> d) (d -> String) String)
-> String -> Pattern (d -> d) (d -> String) String
forall a b. (a -> b) -> a -> b
$ String
"month: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Month cal -> String
forall a. Show a => a -> String
show Month cal
fm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Month cal -> String
forall a. Show a => a -> String
show Month cal
lm
  where
    caseInsensitiveChar :: Char -> ParsecT s u m Char
caseInsensitiveChar Char
c = do
      Char
_ <- Char -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char (Char -> Char
toLower Char
c) ParsecT s u m Char -> ParsecT s u m Char -> ParsecT s u m Char
forall a. ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char (Char -> Char
toUpper Char
c)
      Char -> ParsecT s u m Char
forall a. a -> ParsecT s u m a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
c
    caseInsensitiveString :: String -> ParsecT String u Identity String
caseInsensitiveString = (Char -> ParsecT String u Identity Char)
-> String -> ParsecT String u Identity String
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
caseInsensitiveChar
    fm :: Month cal
fm = Month cal
forall a. Bounded a => a
minBound :: Month cal
    lm :: Month cal
lm = Month cal
forall a. Bounded a => a
maxBound :: Month cal
    months :: ParsecT String () Identity String
months = [ParsecT String () Identity String]
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice ([ParsecT String () Identity String]
 -> ParsecT String () Identity String)
-> ([Month cal] -> [ParsecT String () Identity String])
-> [Month cal]
-> ParsecT String () Identity String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Month cal -> ParsecT String () Identity String)
-> [Month cal] -> [ParsecT String () Identity String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ParsecT String () Identity String
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT String () Identity String
 -> ParsecT String () Identity String)
-> (Month cal -> ParsecT String () Identity String)
-> Month cal
-> ParsecT String () Identity String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ParsecT String () Identity String
forall {u}. String -> ParsecT String u Identity String
caseInsensitiveString (String -> ParsecT String () Identity String)
-> (Month cal -> String)
-> Month cal
-> ParsecT String () Identity String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Month cal -> String
forall a. Show a => a -> String
show) ([Month cal] -> ParsecT String () Identity String)
-> [Month cal] -> ParsecT String () Identity String
forall a b. (a -> b) -> a -> b
$ [Month cal
fm..Month cal
lm]
    p' :: Parser Year String
p' = (Month cal -> Year
forall a. Enum a => a -> Year
fromEnum :: Month cal -> Int) (Month cal -> Year) -> (String -> Month cal) -> String -> Year
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Month cal
forall a. Read a => String -> a
read (String -> Year)
-> ParsecT String () Identity String -> Parser Year String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity String
months
    fmt' :: (d -> Year) -> Format String (d -> String)
fmt' d -> Year
x = (d -> Builder) -> Format String (d -> String)
forall a r. (a -> Builder) -> Format r (a -> r)
later (Text -> Builder
TLB.fromText (Text -> Builder) -> (d -> Text) -> d -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (d -> String) -> d -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Month cal -> String
forall a. Show a => a -> String
show (Month cal -> String) -> (d -> Month cal) -> d -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Year -> Month cal
forall a. Enum a => Year -> a
toEnum :: Int -> Month cal) (Year -> Month cal) -> (d -> Year) -> d -> Month cal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. d -> Year
x)

-- | Day of month - zero-padded
pdd :: HasDate d => Pattern (d -> d) (d -> String) String
pdd :: forall d. HasDate d => Pattern (d -> d) (d -> String) String
pdd = Lens d d Year Year
-> Parser Year String
-> ((d -> Year) -> Format String (d -> String))
-> String
-> Pattern (d -> d) (d -> String) String
forall s a.
Lens s s a a
-> Parser a String
-> ((s -> a) -> Format String (s -> String))
-> String
-> Pattern (s -> s) (s -> String) String
pat_lens (Year -> f Year) -> d -> f d
forall d (f :: * -> *).
(HasDate d, Functor f) =>
(Year -> f Year) -> d -> f d
Lens d d Year Year
CDT.day (Parser Year String
forall {u}. ParsecT String u Identity Year
p_a Parser Year String -> Parser Year String -> Parser Year String
forall a.
ParsecT String () Identity a
-> ParsecT String () Identity a -> ParsecT String () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Year String
forall {u}. ParsecT String u Identity Year
p_b) (d -> Year) -> Format String (d -> String)
forall {b} {a} {r'}. Show b => (a -> b) -> Format r' (a -> r')
f_shown_two String
"day: 01-31"
  where
    p_a :: ParsecT String u Identity Year
p_a = Char -> Char -> Year
forall n. (Num n, Read n) => Char -> Char -> n
digitsToInt (Char -> Char -> Year)
-> ParsecT String u Identity Char
-> ParsecT String u Identity (Char -> Year)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf [Char
'0'..Char
'2'] ParsecT String u Identity (Char -> Year)
-> ParsecT String u Identity Char -> ParsecT String u Identity Year
forall a b.
ParsecT String u Identity (a -> b)
-> ParsecT String u Identity a -> ParsecT String u Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT String u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
    p_b :: ParsecT String u Identity Year
p_b = Char -> Char -> Year
forall n. (Num n, Read n) => Char -> Char -> n
digitsToInt (Char -> Char -> Year)
-> ParsecT String u Identity Char
-> ParsecT String u Identity (Char -> Year)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'3' ParsecT String u Identity (Char -> Year)
-> ParsecT String u Identity Char -> ParsecT String u Identity Year
forall a b.
ParsecT String u Identity (a -> b)
-> ParsecT String u Identity a -> ParsecT String u Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf [Char
'0', Char
'1']

-- | This is the short date pattern, currently defined as "dd/MM/yyyy".
pd :: HasDate d => Pattern (d -> d) (d -> String) String
pd :: forall d. HasDate d => Pattern (d -> d) (d -> String) String
pd = Pattern (d -> d) (d -> String) String
forall d. HasDate d => Pattern (d -> d) (d -> String) String
pdd Pattern (d -> d) (d -> String) String
-> Pattern Char String String
-> Pattern (d -> d) (d -> String) String
forall a b r c. Pattern a b r -> Pattern c r r -> Pattern a b r
<% Char -> Pattern Char String String
char Char
'/' Pattern (d -> d) (d -> String) String
-> Pattern (d -> d) (d -> String) String
-> Pattern (d -> d) (d -> String) String
forall a. Semigroup a => a -> a -> a
<> Pattern (d -> d) (d -> String) String
forall d. HasDate d => Pattern (d -> d) (d -> String) String
pMM Pattern (d -> d) (d -> String) String
-> Pattern Char String String
-> Pattern (d -> d) (d -> String) String
forall a b r c. Pattern a b r -> Pattern c r r -> Pattern a b r
<% Char -> Pattern Char String String
char Char
'/' Pattern (d -> d) (d -> String) String
-> Pattern (d -> d) (d -> String) String
-> Pattern (d -> d) (d -> String) String
forall a. Semigroup a => a -> a -> a
<> Pattern (d -> d) (d -> String) String
forall d. HasDate d => Pattern (d -> d) (d -> String) String
pyyyy

-- | This is the long date pattern, currently defined as "dddd, dd MMMM yyyy".
pD :: (HasDate (c cal), IsCalendar cal, Bounded (Month cal), Read (Month cal), Show (Month cal), Enum (Month cal)) => Pattern (c cal -> c cal) (c cal -> String) String
pD :: forall (c :: * -> *) cal.
(HasDate (c cal), IsCalendar cal, Bounded (Month cal),
 Read (Month cal), Show (Month cal), Enum (Month cal)) =>
Pattern (c cal -> c cal) (c cal -> String) String
pD = Pattern (c cal -> c cal) (c cal -> String) String
forall d. HasDate d => Pattern (d -> d) (d -> String) String
pdd Pattern (c cal -> c cal) (c cal -> String) String
-> Pattern Char String String
-> Pattern (c cal -> c cal) (c cal -> String) String
forall a b r c. Pattern a b r -> Pattern c r r -> Pattern a b r
<% Char -> Pattern Char String String
char Char
' ' Pattern (c cal -> c cal) (c cal -> String) String
-> Pattern (c cal -> c cal) (c cal -> String) String
-> Pattern (c cal -> c cal) (c cal -> String) String
forall a. Semigroup a => a -> a -> a
<> Pattern (c cal -> c cal) (c cal -> String) String
forall cal d (c :: * -> *).
(d ~ c cal, IsCalendar cal, HasDate d, Bounded (Month cal),
 Read (Month cal), Show (Month cal), Enum (Month cal)) =>
Pattern (d -> d) (d -> String) String
pMMMM Pattern (c cal -> c cal) (c cal -> String) String
-> Pattern Char String String
-> Pattern (c cal -> c cal) (c cal -> String) String
forall a b r c. Pattern a b r -> Pattern c r r -> Pattern a b r
<% Char -> Pattern Char String String
char Char
' ' Pattern (c cal -> c cal) (c cal -> String) String
-> Pattern (c cal -> c cal) (c cal -> String) String
-> Pattern (c cal -> c cal) (c cal -> String) String
forall a. Semigroup a => a -> a -> a
<> Pattern (c cal -> c cal) (c cal -> String) String
forall d. HasDate d => Pattern (d -> d) (d -> String) String
pyyyy