{-# LANGUAGE TemplateHaskell #-}
-- | 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, 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 s :: String
s = case [(UTCTime, String)] -> [(UTCTime, String)]
forall a. Eq a => [a] -> [a]
nub ([(UTCTime, String)] -> [(UTCTime, String)])
-> [(UTCTime, String)] -> [(UTCTime, String)]
forall a b. (a -> b) -> a -> b
$ ReadP UTCTime -> ReadS UTCTime
forall a. ReadP a -> ReadS a
readP_to_S ReadP UTCTime
forall (m :: * -> *). DateParsing m => m UTCTime
utcTime String
s of
    [(UTCTime (ModifiedJulianDay d :: Integer
d) dt :: DiffTime
dt, "")] ->
        [| UTCTime (ModifiedJulianDay $(d')) $(dt') :: UTCTime |]
      where
        d' :: Q Exp
d'  = Lit -> Q Exp
litE (Lit -> Q Exp) -> Lit -> Q Exp
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
integerL Integer
d
        dt' :: Q Exp
dt' = Lit -> Q Exp
litE (Lit -> Q Exp) -> Lit -> Q Exp
forall a b. (a -> b) -> a -> b
$ Rational -> Lit
rationalL (Rational -> Lit) -> Rational -> Lit
forall a b. (a -> b) -> a -> b
$ DiffTime -> Rational
forall a. Real a => a -> Rational
toRational DiffTime
dt
    ps :: [(UTCTime, String)]
ps -> String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ "Cannot parse date: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ " -- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(UTCTime, String)] -> String
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 s :: String
s = case [(Day, String)] -> [(Day, String)]
forall a. Eq a => [a] -> [a]
nub ([(Day, String)] -> [(Day, String)])
-> [(Day, String)] -> [(Day, String)]
forall a b. (a -> b) -> a -> b
$ ReadP Day -> ReadS Day
forall a. ReadP a -> ReadS a
readP_to_S ReadP Day
forall (m :: * -> *). DateParsing m => m Day
day String
s of
    [(ModifiedJulianDay d :: Integer
d, "")] ->
        [| ModifiedJulianDay $(d') :: Day |]
      where
        d' :: Q Exp
d'  = Lit -> Q Exp
litE (Lit -> Q Exp) -> Lit -> Q Exp
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
integerL Integer
d
    ps :: [(Day, String)]
ps -> String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ "Cannot parse day: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ " -- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(Day, String)] -> String
forall a. Show a => a -> String
show [(Day, String)]
ps