{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE TemplateHaskellQuotes #-}
#else
{-# LANGUAGE TemplateHaskell #-}
#endif
-- | Template Haskell extras for `Data.Time`.
module Data.Time.TH (mkUTCTime, mkDay) where

import Data.List                    (nub)
import Data.Time                    (Day (..), UTCTime (..))
import Data.Time.Parsers            (day, utcTime)
import Language.Haskell.TH          (Exp, Q, integerL, litE, appE, sigE, rationalL)
import Text.ParserCombinators.ReadP (readP_to_S)

-- | Make  a 'UTCTime'. Accepts the same strings as  `utcTime` parser accepts.
--
-- > t :: UTCTime
-- > t = $(mkUTCTime "2014-05-12 00:02:03.456000Z")
mkUTCTime :: String -> Q Exp
mkUTCTime :: String -> Q Exp
mkUTCTime String
s = case forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall a. ReadP a -> ReadS a
readP_to_S forall (m :: * -> *). DateParsing m => m UTCTime
utcTime String
s of
    [(UTCTime (ModifiedJulianDay Integer
d) DiffTime
dt, String
"")] ->
        ([| UTCTime |] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ([| ModifiedJulianDay |] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
d') forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
dt') forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
`sigE` [t| UTCTime |]
      where
        d' :: Q Exp
d'  = forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall a b. (a -> b) -> a -> b
$ Integer -> Lit
integerL Integer
d
        dt' :: Q Exp
dt' = forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall a b. (a -> b) -> a -> b
$ Rational -> Lit
rationalL forall a b. (a -> b) -> a -> b
$ forall a. Real a => a -> Rational
toRational DiffTime
dt
    [(UTCTime, String)]
ps -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Cannot parse date: " forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ String
" -- " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [(UTCTime, String)]
ps

-- | Make  a 'Day'. Accepts the same strings as  `day` parser accepts.
--
-- > d :: Day
-- > d = $(mkDay "2014-05-12")
mkDay :: String -> Q Exp
mkDay :: String -> Q Exp
mkDay String
s = case forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall a. ReadP a -> ReadS a
readP_to_S forall (m :: * -> *). DateParsing m => m Day
day String
s of
    [(ModifiedJulianDay Integer
d, String
"")] ->
        ([| ModifiedJulianDay |] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
d') forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
`sigE` [t| Day |]
      where
        d' :: Q Exp
d'  = forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall a b. (a -> b) -> a -> b
$ Integer -> Lit
integerL Integer
d
    [(Day, String)]
ps -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Cannot parse day: " forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ String
" -- " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [(Day, String)]
ps