{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE TemplateHaskellQuotes #-}
#else
{-# LANGUAGE TemplateHaskell #-}
#endif
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)
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
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