{-# 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 Int Int
-> Parser Int String
-> ((d -> Int) -> 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 (Int -> f Int) -> d -> f d
forall d (f :: * -> *).
(HasDate d, Functor f) =>
(Int -> f Int) -> d -> f d
Lens d d Int Int
CDT.year Parser Int String
forall {u}. ParsecT String u Identity Int
p (d -> Int) -> Format String (d -> String)
forall {b} {t} {r'}. Show b => (t -> b) -> Format r' (t -> r')
fmt String
"year: 0000-9999"
  where
    p :: ParsecT String u Identity Int
p = String -> Int
forall a. Read a => String -> a
read (String -> Int)
-> ParsecT String u Identity String
-> ParsecT String u Identity Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> ParsecT String u Identity Char
-> ParsecT String u Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
Int -> ParsecT s u m a -> ParsecT s u m [a]
count Int
4 ParsecT String u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
    fmt :: (t -> b) -> Format r' (t -> r')
fmt t -> b
x = Int -> Char -> Format r' (Builder -> r')
forall a r. Buildable a => Int -> Char -> Format r (a -> r)
left Int
4 Char
'0' Format r' (Builder -> r')
-> Format r' (t -> r') -> Format r' (t -> r')
forall r r' a.
Format r (Builder -> r') -> Format r' a -> Format r a
%. (t -> b) -> Format r' (t -> r')
forall {b} {t} {r'}. Show b => (t -> b) -> Format r' (t -> r')
f_shown t -> 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 Int Int
-> Parser Int String
-> ((d -> Int) -> 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 (Int -> f Int) -> d -> f d
forall d (f :: * -> *).
(HasDate d, Functor f) =>
(Int -> f Int) -> d -> f d
Lens d d Int Int
monthl Parser Int String
p (d -> Int) -> Format String (d -> String)
forall {a} {t} {r'}.
(Show a, Enum a) =>
(t -> a) -> Format r' (t -> r')
fmt String
"month: 01-12"
  where
    p :: Parser Int String
p = Int -> Int
forall a. Enum a => a -> a
pred (Int -> Int) -> Parser Int String -> Parser Int String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser Int String
forall {u}. ParsecT String u Identity Int
p_a Parser Int String -> Parser Int String -> Parser Int 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 Int String
forall {u}. ParsecT String u Identity Int
p_b)
    p_a :: ParsecT String u Identity Int
p_a = Char -> Char -> Int
forall n. (Num n, Read n) => Char -> Char -> n
digitsToInt (Char -> Char -> Int)
-> ParsecT String u Identity Char
-> ParsecT String u Identity (Char -> Int)
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 -> Int)
-> ParsecT String u Identity Char -> ParsecT String u Identity Int
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 Int
p_b = Char -> Char -> Int
forall n. (Num n, Read n) => Char -> Char -> n
digitsToInt (Char -> Char -> Int)
-> ParsecT String u Identity Char
-> ParsecT String u Identity (Char -> Int)
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 -> Int)
-> ParsecT String u Identity Char -> ParsecT String u Identity Int
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 :: (t -> a) -> Format r' (t -> r')
fmt t -> a
x = Int -> Char -> Format r' (Builder -> r')
forall a r. Buildable a => Int -> Char -> Format r (a -> r)
left Int
2 Char
'0' Format r' (Builder -> r')
-> Format r' (t -> r') -> Format r' (t -> r')
forall r r' a.
Format r (Builder -> r') -> Format r' a -> Format r a
%. (t -> Builder) -> Format r' (t -> r')
forall a r. (a -> Builder) -> Format r (a -> r)
later (Text -> Builder
TLB.fromText (Text -> Builder) -> (t -> Text) -> t -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (t -> String) -> t -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show (a -> String) -> (t -> a) -> t -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
forall a. Enum a => a -> a
succ (a -> a) -> (t -> a) -> t -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> a
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 Int Int
-> Parser Int String
-> ((d -> Int) -> 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 (Int -> f Int) -> d -> f d
forall d (f :: * -> *).
(HasDate d, Functor f) =>
(Int -> f Int) -> d -> f d
Lens d d Int Int
monthl Parser Int String
p' (d -> Int) -> 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 -> 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)
      return 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 Int String
p' = (Month cal -> Int
forall a. Enum a => a -> Int
fromEnum :: Month cal -> Int) (Month cal -> Int) -> (String -> Month cal) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Month cal
forall a. Read a => String -> a
read (String -> Int)
-> ParsecT String () Identity String -> Parser Int String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity String
months
    fmt' :: (d -> Int) -> Format String (d -> String)
fmt' d -> Int
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
. (Int -> Month cal
forall a. Enum a => Int -> a
toEnum :: Int -> Month cal) (Int -> Month cal) -> (d -> Int) -> d -> Month cal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. d -> Int
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 Int Int
-> Parser Int String
-> ((d -> Int) -> 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 (Int -> f Int) -> d -> f d
forall d (f :: * -> *).
(HasDate d, Functor f) =>
(Int -> f Int) -> d -> f d
Lens d d Int Int
CDT.day (Parser Int String
forall {u}. ParsecT String u Identity Int
p_a Parser Int String -> Parser Int String -> Parser Int 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 Int String
forall {u}. ParsecT String u Identity Int
p_b) (d -> Int) -> Format String (d -> String)
forall {b} {t} {r'}. Show b => (t -> b) -> Format r' (t -> r')
f_shown_two String
"day: 01-31"
  where
    p_a :: ParsecT String u Identity Int
p_a = Char -> Char -> Int
forall n. (Num n, Read n) => Char -> Char -> n
digitsToInt (Char -> Char -> Int)
-> ParsecT String u Identity Char
-> ParsecT String u Identity (Char -> Int)
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 -> Int)
-> ParsecT String u Identity Char -> ParsecT String u Identity Int
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 Int
p_b = Char -> Char -> Int
forall n. (Num n, Read n) => Char -> Char -> n
digitsToInt (Char -> Char -> Int)
-> ParsecT String u Identity Char
-> ParsecT String u Identity (Char -> Int)
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 -> Int)
-> ParsecT String u Identity Char -> ParsecT String u Identity Int
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