{-# 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 [(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 Integer
d) DiffTime
dt, String
"")] ->
([| UTCTime |] Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ([| ModifiedJulianDay |] Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
d') Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
dt') Q Exp -> Q Type -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
`sigE` [t| UTCTime |]
where
d' :: Q Exp
d' = Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m 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
forall (m :: * -> *). Quote m => Lit -> m 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
[(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
$ String
"Cannot parse date: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(UTCTime, String)] -> String
forall a. Show a => a -> String
show [(UTCTime, String)]
ps
mkDay :: String -> Q Exp
mkDay :: String -> Q Exp
mkDay 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 Integer
d, String
"")] ->
([| ModifiedJulianDay |] Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
d') Q Exp -> Q Type -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
`sigE` [t| Day |]
where
d' :: Q Exp
d' = Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> Q Exp) -> Lit -> Q Exp
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
integerL Integer
d
[(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
$ String
"Cannot parse day: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(Day, String)] -> String
forall a. Show a => a -> String
show [(Day, String)]
ps