{-# LANGUAGE UnicodeSyntax, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, LambdaCase, QuasiQuotes, TemplateHaskell #-}
-- | This module allows to parse arbitrary date formats.
-- Date formats are specified as strings:
--
--  * "DD.MM.YYY"
--
--  * "YYYY\/MM\/DD"
--
--  * "DD\/MM\/YYYY, HH:mm:SS"
--
--  * "YY.MM.DD[, HH:mm:SS]"
--
--  * and so on.
--
module Data.Dates.Formats
  (FormatElement (..), Format,
   FormatParser,
   parseFormat, pFormat, formatParser,
   parseDateFormat,
   df
  ) where

import Control.Applicative ((<$>))
import Data.Monoid
import Text.Parsec
import Language.Haskell.TH
import Language.Haskell.TH.Quote (QuasiQuoter(..))

import Data.Dates.Types
import Data.Dates.Internal (number)

-- | Date\/time format element
data FormatElement =
    YEAR   Bool Int
  | MONTH  Bool Int
  | DAY    Bool Int
  | HOUR   Bool Int
  | MINUTE Bool Int
  | SECOND Bool Int
  | Whitespace Bool
  | Fixed  Bool String
  deriving (FormatElement -> FormatElement -> Bool
(FormatElement -> FormatElement -> Bool)
-> (FormatElement -> FormatElement -> Bool) -> Eq FormatElement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FormatElement -> FormatElement -> Bool
$c/= :: FormatElement -> FormatElement -> Bool
== :: FormatElement -> FormatElement -> Bool
$c== :: FormatElement -> FormatElement -> Bool
Eq, Int -> FormatElement -> ShowS
[FormatElement] -> ShowS
FormatElement -> String
(Int -> FormatElement -> ShowS)
-> (FormatElement -> String)
-> ([FormatElement] -> ShowS)
-> Show FormatElement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FormatElement] -> ShowS
$cshowList :: [FormatElement] -> ShowS
show :: FormatElement -> String
$cshow :: FormatElement -> String
showsPrec :: Int -> FormatElement -> ShowS
$cshowsPrec :: Int -> FormatElement -> ShowS
Show)

type FormatParser a = Parsec String Bool a

-- | Date\/time format
type Format = [FormatElement]

nchars ∷ Char → FormatParser Int
nchars :: Char -> FormatParser Int
nchars Char
c = do
  String
s ← ParsecT String Bool Identity Char
-> ParsecT String Bool Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT String Bool Identity Char
 -> ParsecT String Bool Identity String)
-> ParsecT String Bool Identity Char
-> ParsecT String Bool Identity String
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT String Bool Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
c
  Int -> FormatParser Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> FormatParser Int) -> Int -> FormatParser Int
forall a b. (a -> b) -> a -> b
$ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s

brackets :: FormatParser a -> FormatParser a
brackets :: FormatParser a -> FormatParser a
brackets FormatParser a
p = do
  Char -> ParsecT String Bool Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'['
  Bool -> ParsecT String Bool Identity ()
forall (m :: * -> *) u s. Monad m => u -> ParsecT s u m ()
setState Bool
False
  a
result <- FormatParser a
p
  Char -> ParsecT String Bool Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
']'
  Bool -> ParsecT String Bool Identity ()
forall (m :: * -> *) u s. Monad m => u -> ParsecT s u m ()
setState Bool
True
  a -> FormatParser a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result

pFormat :: FormatParser Format
pFormat :: FormatParser [FormatElement]
pFormat = do
    [[FormatElement]]
elems <- FormatParser [FormatElement]
-> ParsecT String Bool Identity [[FormatElement]]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (FormatParser [FormatElement]
 -> ParsecT String Bool Identity [[FormatElement]])
-> FormatParser [FormatElement]
-> ParsecT String Bool Identity [[FormatElement]]
forall a b. (a -> b) -> a -> b
$ FormatParser [FormatElement] -> FormatParser [FormatElement]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (FormatParser [FormatElement] -> FormatParser [FormatElement]
forall a. FormatParser a -> FormatParser a
brackets FormatParser [FormatElement]
format) FormatParser [FormatElement]
-> FormatParser [FormatElement] -> FormatParser [FormatElement]
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> FormatParser [FormatElement]
format
    [FormatElement] -> FormatParser [FormatElement]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FormatElement] -> FormatParser [FormatElement])
-> [FormatElement] -> FormatParser [FormatElement]
forall a b. (a -> b) -> a -> b
$ [[FormatElement]] -> [FormatElement]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FormatElement]]
elems

  where
    format :: FormatParser Format
    format :: FormatParser [FormatElement]
format =
      ParsecT String Bool Identity FormatElement
-> FormatParser [FormatElement]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT String Bool Identity FormatElement
 -> FormatParser [FormatElement])
-> ParsecT String Bool Identity FormatElement
-> FormatParser [FormatElement]
forall a b. (a -> b) -> a -> b
$ [ParsecT String Bool Identity FormatElement]
-> ParsecT String Bool Identity FormatElement
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice ([ParsecT String Bool Identity FormatElement]
 -> ParsecT String Bool Identity FormatElement)
-> [ParsecT String Bool Identity FormatElement]
-> ParsecT String Bool Identity FormatElement
forall a b. (a -> b) -> a -> b
$ (ParsecT String Bool Identity FormatElement
 -> ParsecT String Bool Identity FormatElement)
-> [ParsecT String Bool Identity FormatElement]
-> [ParsecT String Bool Identity FormatElement]
forall a b. (a -> b) -> [a] -> [b]
map ParsecT String Bool Identity FormatElement
-> ParsecT String Bool Identity FormatElement
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try [(Bool -> Int -> FormatElement)
-> Char -> ParsecT String Bool Identity FormatElement
forall b.
(Bool -> Int -> b) -> Char -> ParsecT String Bool Identity b
element Bool -> Int -> FormatElement
YEAR Char
'Y', (Bool -> Int -> FormatElement)
-> Char -> ParsecT String Bool Identity FormatElement
forall b.
(Bool -> Int -> b) -> Char -> ParsecT String Bool Identity b
element Bool -> Int -> FormatElement
MONTH Char
'M',
                                         (Bool -> Int -> FormatElement)
-> Char -> ParsecT String Bool Identity FormatElement
forall b.
(Bool -> Int -> b) -> Char -> ParsecT String Bool Identity b
element Bool -> Int -> FormatElement
DAY  Char
'D', (Bool -> Int -> FormatElement)
-> Char -> ParsecT String Bool Identity FormatElement
forall b.
(Bool -> Int -> b) -> Char -> ParsecT String Bool Identity b
element Bool -> Int -> FormatElement
HOUR  Char
'H',
                                         (Bool -> Int -> FormatElement)
-> Char -> ParsecT String Bool Identity FormatElement
forall b.
(Bool -> Int -> b) -> Char -> ParsecT String Bool Identity b
element Bool -> Int -> FormatElement
MINUTE Char
'm', (Bool -> Int -> FormatElement)
-> Char -> ParsecT String Bool Identity FormatElement
forall b.
(Bool -> Int -> b) -> Char -> ParsecT String Bool Identity b
element Bool -> Int -> FormatElement
SECOND Char
'S',
                                         ParsecT String Bool Identity FormatElement
whitespaces, ParsecT String Bool Identity FormatElement
fixed]

    element :: (Bool -> Int -> b) -> Char -> ParsecT String Bool Identity b
element Bool -> Int -> b
constr Char
c = do
      Bool
mandatory <- ParsecT String Bool Identity Bool
forall (m :: * -> *) s u. Monad m => ParsecT s u m u
getState
      Bool -> Int -> b
constr Bool
mandatory (Int -> b) -> FormatParser Int -> ParsecT String Bool Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> FormatParser Int
nchars Char
c

    whitespaces :: ParsecT String Bool Identity FormatElement
whitespaces = do
      ParsecT String Bool Identity Char
-> ParsecT String Bool Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT String Bool Identity Char
 -> ParsecT String Bool Identity String)
-> ParsecT String Bool Identity Char
-> ParsecT String Bool Identity String
forall a b. (a -> b) -> a -> b
$ String -> ParsecT String Bool Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
" \r\n\t"
      Bool
mandatory <- ParsecT String Bool Identity Bool
forall (m :: * -> *) s u. Monad m => ParsecT s u m u
getState
      FormatElement -> ParsecT String Bool Identity FormatElement
forall (m :: * -> *) a. Monad m => a -> m a
return (FormatElement -> ParsecT String Bool Identity FormatElement)
-> FormatElement -> ParsecT String Bool Identity FormatElement
forall a b. (a -> b) -> a -> b
$ Bool -> FormatElement
Whitespace Bool
mandatory

    fixed :: ParsecT String Bool Identity FormatElement
fixed = do
      Bool
mandatory <- ParsecT String Bool Identity Bool
forall (m :: * -> *) s u. Monad m => ParsecT s u m u
getState
      Bool -> String -> FormatElement
Fixed Bool
mandatory (String -> FormatElement)
-> ParsecT String Bool Identity String
-> ParsecT String Bool Identity FormatElement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT String Bool Identity Char
-> ParsecT String Bool Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT String Bool Identity Char
 -> ParsecT String Bool Identity String)
-> ParsecT String Bool Identity Char
-> ParsecT String Bool Identity String
forall a b. (a -> b) -> a -> b
$ String -> ParsecT String Bool Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"YMDHmS[] \t\r\n")

pYear ∷ Stream s m Char => Int → ParsecT s st m DateTime
pYear :: Int -> ParsecT s st m DateTime
pYear Int
n = do
  Int
y ← Int -> Int -> ParsecT s st m Int
forall s (m :: * -> *) st.
Stream s m Char =>
Int -> Int -> ParsecT s st m Int
number Int
n Int
10000
  if Int
y Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2000
    then DateTime -> ParsecT s st m DateTime
forall (m :: * -> *) a. Monad m => a -> m a
return (DateTime -> ParsecT s st m DateTime)
-> DateTime -> ParsecT s st m DateTime
forall a b. (a -> b) -> a -> b
$ DateTime
forall a. Monoid a => a
mempty {year :: Int
year = Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2000}
    else DateTime -> ParsecT s st m DateTime
forall (m :: * -> *) a. Monad m => a -> m a
return (DateTime -> ParsecT s st m DateTime)
-> DateTime -> ParsecT s st m DateTime
forall a b. (a -> b) -> a -> b
$ DateTime
forall a. Monoid a => a
mempty {year :: Int
year = Int
y}

pMonth ∷ Stream s m Char => Int → ParsecT s st m DateTime
pMonth :: Int -> ParsecT s st m DateTime
pMonth Int
n = do
  Int
m ← Int -> Int -> ParsecT s st m Int
forall s (m :: * -> *) st.
Stream s m Char =>
Int -> Int -> ParsecT s st m Int
number Int
n Int
12
  DateTime -> ParsecT s st m DateTime
forall (m :: * -> *) a. Monad m => a -> m a
return (DateTime -> ParsecT s st m DateTime)
-> DateTime -> ParsecT s st m DateTime
forall a b. (a -> b) -> a -> b
$ DateTime
forall a. Monoid a => a
mempty {month :: Int
month = Int
m}

pDay ∷ Stream s m Char => Int → ParsecT s st m DateTime
pDay :: Int -> ParsecT s st m DateTime
pDay Int
n = do
  Int
d ← Int -> Int -> ParsecT s st m Int
forall s (m :: * -> *) st.
Stream s m Char =>
Int -> Int -> ParsecT s st m Int
number Int
n Int
31
  DateTime -> ParsecT s st m DateTime
forall (m :: * -> *) a. Monad m => a -> m a
return (DateTime -> ParsecT s st m DateTime)
-> DateTime -> ParsecT s st m DateTime
forall a b. (a -> b) -> a -> b
$ DateTime
forall a. Monoid a => a
mempty {day :: Int
day = Int
d}

pHour ∷ Stream s m Char => Int → ParsecT s st m DateTime
pHour :: Int -> ParsecT s st m DateTime
pHour Int
n = do
  Int
h ← Int -> Int -> ParsecT s st m Int
forall s (m :: * -> *) st.
Stream s m Char =>
Int -> Int -> ParsecT s st m Int
number Int
n Int
23
  DateTime -> ParsecT s st m DateTime
forall (m :: * -> *) a. Monad m => a -> m a
return (DateTime -> ParsecT s st m DateTime)
-> DateTime -> ParsecT s st m DateTime
forall a b. (a -> b) -> a -> b
$ DateTime
forall a. Monoid a => a
mempty {hour :: Int
hour = Int
h}

pMinute ∷ Stream s m Char => Int → ParsecT s st m DateTime
pMinute :: Int -> ParsecT s st m DateTime
pMinute Int
n = do
  Int
m ← Int -> Int -> ParsecT s st m Int
forall s (m :: * -> *) st.
Stream s m Char =>
Int -> Int -> ParsecT s st m Int
number Int
n Int
59
  DateTime -> ParsecT s st m DateTime
forall (m :: * -> *) a. Monad m => a -> m a
return (DateTime -> ParsecT s st m DateTime)
-> DateTime -> ParsecT s st m DateTime
forall a b. (a -> b) -> a -> b
$ DateTime
forall a. Monoid a => a
mempty {minute :: Int
minute = Int
m}

pSecond ∷ Stream s m Char => Int → ParsecT s st m DateTime
pSecond :: Int -> ParsecT s st m DateTime
pSecond Int
n = do
  Int
s ← Int -> Int -> ParsecT s st m Int
forall s (m :: * -> *) st.
Stream s m Char =>
Int -> Int -> ParsecT s st m Int
number Int
n Int
59
  DateTime -> ParsecT s st m DateTime
forall (m :: * -> *) a. Monad m => a -> m a
return (DateTime -> ParsecT s st m DateTime)
-> DateTime -> ParsecT s st m DateTime
forall a b. (a -> b) -> a -> b
$ DateTime
forall a. Monoid a => a
mempty {second :: Int
second = Int
s}

opt :: Stream s m Char => Monoid a => Bool -> ParsecT s st m a -> ParsecT s st m a
opt :: Bool -> ParsecT s st m a -> ParsecT s st m a
opt Bool
True  ParsecT s st m a
p = ParsecT s st m a
p
opt Bool
False ParsecT s st m a
p = a -> ParsecT s st m a -> ParsecT s st m a
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option a
forall a. Monoid a => a
mempty ParsecT s st m a
p

parseFormat :: String -> Either ParseError Format
parseFormat :: String -> Either ParseError [FormatElement]
parseFormat String
formatStr = FormatParser [FormatElement]
-> Bool -> String -> String -> Either ParseError [FormatElement]
forall s t u a.
Stream s Identity t =>
Parsec s u a -> u -> String -> s -> Either ParseError a
runParser FormatParser [FormatElement]
pFormat Bool
True String
"(date format string)" String
formatStr

-- | Make Parser for specified date format.
formatParser ∷ Stream s m Char => Format → ParsecT s st m DateTime
formatParser :: [FormatElement] -> ParsecT s st m DateTime
formatParser [FormatElement]
format = [DateTime] -> DateTime
forall a. Monoid a => [a] -> a
mconcat ([DateTime] -> DateTime)
-> ParsecT s st m [DateTime] -> ParsecT s st m DateTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FormatElement -> ParsecT s st m DateTime)
-> [FormatElement] -> ParsecT s st m [DateTime]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FormatElement -> ParsecT s st m DateTime
forall s (m :: * -> *) st.
Stream s m Char =>
FormatElement -> ParsecT s st m DateTime
parser [FormatElement]
format
  where
    parser :: FormatElement -> ParsecT s st m DateTime
parser (YEAR   Bool
m Int
n) = Bool -> ParsecT s st m DateTime -> ParsecT s st m DateTime
forall s (m :: * -> *) a st.
(Stream s m Char, Monoid a) =>
Bool -> ParsecT s st m a -> ParsecT s st m a
opt Bool
m (ParsecT s st m DateTime -> ParsecT s st m DateTime)
-> ParsecT s st m DateTime -> ParsecT s st m DateTime
forall a b. (a -> b) -> a -> b
$ Int -> ParsecT s st m DateTime
forall s (m :: * -> *) st.
Stream s m Char =>
Int -> ParsecT s st m DateTime
pYear Int
n
    parser (MONTH  Bool
m Int
n) = Bool -> ParsecT s st m DateTime -> ParsecT s st m DateTime
forall s (m :: * -> *) a st.
(Stream s m Char, Monoid a) =>
Bool -> ParsecT s st m a -> ParsecT s st m a
opt Bool
m (ParsecT s st m DateTime -> ParsecT s st m DateTime)
-> ParsecT s st m DateTime -> ParsecT s st m DateTime
forall a b. (a -> b) -> a -> b
$ Int -> ParsecT s st m DateTime
forall s (m :: * -> *) st.
Stream s m Char =>
Int -> ParsecT s st m DateTime
pMonth Int
n
    parser (DAY    Bool
m Int
n) = Bool -> ParsecT s st m DateTime -> ParsecT s st m DateTime
forall s (m :: * -> *) a st.
(Stream s m Char, Monoid a) =>
Bool -> ParsecT s st m a -> ParsecT s st m a
opt Bool
m (ParsecT s st m DateTime -> ParsecT s st m DateTime)
-> ParsecT s st m DateTime -> ParsecT s st m DateTime
forall a b. (a -> b) -> a -> b
$ Int -> ParsecT s st m DateTime
forall s (m :: * -> *) st.
Stream s m Char =>
Int -> ParsecT s st m DateTime
pDay Int
n
    parser (HOUR   Bool
m Int
n) = Bool -> ParsecT s st m DateTime -> ParsecT s st m DateTime
forall s (m :: * -> *) a st.
(Stream s m Char, Monoid a) =>
Bool -> ParsecT s st m a -> ParsecT s st m a
opt Bool
m (ParsecT s st m DateTime -> ParsecT s st m DateTime)
-> ParsecT s st m DateTime -> ParsecT s st m DateTime
forall a b. (a -> b) -> a -> b
$ Int -> ParsecT s st m DateTime
forall s (m :: * -> *) st.
Stream s m Char =>
Int -> ParsecT s st m DateTime
pHour Int
n
    parser (MINUTE Bool
m Int
n) = Bool -> ParsecT s st m DateTime -> ParsecT s st m DateTime
forall s (m :: * -> *) a st.
(Stream s m Char, Monoid a) =>
Bool -> ParsecT s st m a -> ParsecT s st m a
opt Bool
m (ParsecT s st m DateTime -> ParsecT s st m DateTime)
-> ParsecT s st m DateTime -> ParsecT s st m DateTime
forall a b. (a -> b) -> a -> b
$ Int -> ParsecT s st m DateTime
forall s (m :: * -> *) st.
Stream s m Char =>
Int -> ParsecT s st m DateTime
pMinute Int
n
    parser (SECOND Bool
m Int
n) = Bool -> ParsecT s st m DateTime -> ParsecT s st m DateTime
forall s (m :: * -> *) a st.
(Stream s m Char, Monoid a) =>
Bool -> ParsecT s st m a -> ParsecT s st m a
opt Bool
m (ParsecT s st m DateTime -> ParsecT s st m DateTime)
-> ParsecT s st m DateTime -> ParsecT s st m DateTime
forall a b. (a -> b) -> a -> b
$ Int -> ParsecT s st m DateTime
forall s (m :: * -> *) st.
Stream s m Char =>
Int -> ParsecT s st m DateTime
pSecond Int
n
    parser (Whitespace Bool
m) = Bool -> ParsecT s st m DateTime -> ParsecT s st m DateTime
forall s (m :: * -> *) a st.
(Stream s m Char, Monoid a) =>
Bool -> ParsecT s st m a -> ParsecT s st m a
opt Bool
m ((ParsecT s st m Char -> ParsecT s st m String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT s st m Char -> ParsecT s st m String)
-> ParsecT s st m Char -> ParsecT s st m String
forall a b. (a -> b) -> a -> b
$ String -> ParsecT s st m Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
" \t\r\n") ParsecT s st m String
-> ParsecT s st m DateTime -> ParsecT s st m DateTime
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DateTime -> ParsecT s st m DateTime
forall (m :: * -> *) a. Monad m => a -> m a
return DateTime
forall a. Monoid a => a
mempty)
    parser (Fixed  Bool
m String
s) = Bool -> ParsecT s st m DateTime -> ParsecT s st m DateTime
forall s (m :: * -> *) a st.
(Stream s m Char, Monoid a) =>
Bool -> ParsecT s st m a -> ParsecT s st m a
opt Bool
m ( String -> ParsecT s st m String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
s ParsecT s st m String
-> ParsecT s st m DateTime -> ParsecT s st m DateTime
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DateTime -> ParsecT s st m DateTime
forall (m :: * -> *) a. Monad m => a -> m a
return DateTime
forall a. Monoid a => a
mempty )

-- | Parse date\/time in specified format.
parseDateFormat :: String  -- ^ Format string, i.e. "DD.MM.YY"
                -> String  -- ^ String to parse
                -> Either ParseError DateTime
parseDateFormat :: String -> String -> Either ParseError DateTime
parseDateFormat String
formatStr String
str = do
  [FormatElement]
format <- String -> Either ParseError [FormatElement]
parseFormat String
formatStr 
  Parsec String () DateTime
-> () -> String -> String -> Either ParseError DateTime
forall s t u a.
Stream s Identity t =>
Parsec s u a -> u -> String -> s -> Either ParseError a
runParser ([FormatElement] -> Parsec String () DateTime
forall s (m :: * -> *) st.
Stream s m Char =>
[FormatElement] -> ParsecT s st m DateTime
formatParser [FormatElement]
format) () String
"(date)" String
str

df :: QuasiQuoter
df :: QuasiQuoter
df = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
  { quoteExp :: String -> Q Exp
quoteExp = (ParseError -> Q Exp)
-> ([FormatElement] -> Q Exp)
-> Either ParseError [FormatElement]
-> Q Exp
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> (ParseError -> String) -> ParseError -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> String
forall a. Show a => a -> String
show) ([Q Exp] -> Q Exp
listE ([Q Exp] -> Q Exp)
-> ([FormatElement] -> [Q Exp]) -> [FormatElement] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FormatElement -> Q Exp) -> [FormatElement] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FormatElement -> Q Exp
fe2th) (Either ParseError [FormatElement] -> Q Exp)
-> (String -> Either ParseError [FormatElement]) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either ParseError [FormatElement]
parseFormat
  , quotePat :: String -> Q Pat
quotePat = String -> Q Pat
forall b a. b -> Q a
err
  , quoteType :: String -> Q Type
quoteType = String -> Q Type
forall b a. b -> Q a
err
  , quoteDec :: String -> Q [Dec]
quoteDec = String -> Q [Dec]
forall b a. b -> Q a
err
  }
  where
  fe2th :: FormatElement -> ExpQ
  fe2th :: FormatElement -> Q Exp
fe2th = \case
    YEAR       Bool
x Int
y -> [e|YEAR       $(b x) $(i y)      |]
    MONTH      Bool
x Int
y -> [e|MONTH      $(b x) $(i y)      |]
    DAY        Bool
x Int
y -> [e|DAY        $(b x) $(i y)      |]
    HOUR       Bool
x Int
y -> [e|HOUR       $(b x) $(i y)      |]
    MINUTE     Bool
x Int
y -> [e|MINUTE     $(b x) $(i y)      |]
    SECOND     Bool
x Int
y -> [e|SECOND     $(b x) $(i y)      |]
    Whitespace Bool
x   -> [e|Whitespace $(b x)             |]
    Fixed      Bool
x String
y -> [e|Fixed      $(b x) $(stringE y)|]
  err :: b -> Q a
err = Q a -> b -> Q a
forall a b. a -> b -> a
const (Q a -> b -> Q a) -> Q a -> b -> Q a
forall a b. (a -> b) -> a -> b
$ String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Date format parser only defined for Exp"
  b :: Bool -> ExpQ
  b :: Bool -> Q Exp
b = Name -> Q Exp
conE (Name -> Q Exp) -> (Bool -> Name) -> Bool -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    Bool
True  -> 'True
    Bool
False -> 'False
  i :: Int -> ExpQ
  i :: Int -> Q Exp
i = Lit -> Q Exp
litE (Lit -> Q Exp) -> (Int -> Lit) -> Int -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
integerL (Integer -> Lit) -> (Int -> Integer) -> Int -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a. Integral a => a -> Integer
toInteger