{-# LANGUAGE TemplateHaskell #-}
module Data.Time.Clock.Duration.QQ
(
t
, s
, ms
, µs
, ns
, ps
) where
import Control.Applicative ((<|>), liftA2)
import Data.Bool (bool)
import Data.Char (isAlpha, toLower, toUpper)
import Data.Fixed (E0, E3, E6, E9, E12)
import Data.Proxy (Proxy (Proxy))
import Data.Time.Clock.Duration.Types
import Language.Haskell.TH (Exp (AppE, ConE, SigE, VarE), Name, Q, Type (AppT, ConT))
import Language.Haskell.TH.Quote (QuasiQuoter (QuasiQuoter, quoteExp))
import Text.Parsec (char, choice, digit, eof, many1, option, optional, runParser, spaces, try)
import Text.Parsec.String (Parser)
t :: QuasiQuoter
t :: QuasiQuoter
t = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter { quoteExp :: String -> Q Exp
quoteExp = Maybe (Rational -> Time, Name) -> String -> Q Exp
buildExp Maybe (Rational -> Time, Name)
forall a. Maybe a
Nothing }
s :: QuasiQuoter
s :: QuasiQuoter
s = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter { quoteExp :: String -> Q Exp
quoteExp = Maybe (Rational -> Time, Name) -> String -> Q Exp
buildExp ((Rational -> Time, Name) -> Maybe (Rational -> Time, Name)
forall a. a -> Maybe a
Just (Rational -> Time
Second, ''E0)) }
ms :: QuasiQuoter
ms :: QuasiQuoter
ms = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter { quoteExp :: String -> Q Exp
quoteExp = Maybe (Rational -> Time, Name) -> String -> Q Exp
buildExp ((Rational -> Time, Name) -> Maybe (Rational -> Time, Name)
forall a. a -> Maybe a
Just (Rational -> Time
Millisec, ''E3)) }
µs :: QuasiQuoter
µs :: QuasiQuoter
µs = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter { quoteExp :: String -> Q Exp
quoteExp = Maybe (Rational -> Time, Name) -> String -> Q Exp
buildExp ((Rational -> Time, Name) -> Maybe (Rational -> Time, Name)
forall a. a -> Maybe a
Just (Rational -> Time
Microsec, ''E6)) }
ns :: QuasiQuoter
ns :: QuasiQuoter
ns = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter { quoteExp :: String -> Q Exp
quoteExp = Maybe (Rational -> Time, Name) -> String -> Q Exp
buildExp ((Rational -> Time, Name) -> Maybe (Rational -> Time, Name)
forall a. a -> Maybe a
Just (Rational -> Time
Nanosec, ''E9)) }
ps :: QuasiQuoter
ps :: QuasiQuoter
ps = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter { quoteExp :: String -> Q Exp
quoteExp = Maybe (Rational -> Time, Name) -> String -> Q Exp
buildExp ((Rational -> Time, Name) -> Maybe (Rational -> Time, Name)
forall a. a -> Maybe a
Just (Rational -> Time
Picosec, ''E12)) }
buildExp :: Maybe ((Rational -> Time), Name) -> String -> Q Exp
buildExp :: Maybe (Rational -> Time, Name) -> String -> Q Exp
buildExp Maybe (Rational -> Time, Name)
munit String
str =
let duration :: Duration
duration = Parsec String () Duration
-> () -> String -> String -> Either ParseError Duration
forall s t u a.
Stream s Identity t =>
Parsec s u a -> u -> String -> s -> Either ParseError a
runParser Parsec String () Duration
durationP () String
"" String
str Either ParseError Duration -> (ParseError -> Duration) -> Duration
forall t p. Either t p -> (t -> p) -> p
`catch` (String -> Duration
forall a. HasCallStack => String -> a
error (String -> Duration)
-> (ParseError -> String) -> ParseError -> Duration
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> String
forall a. Show a => a -> String
show) in
case (Maybe (Rational -> Time, Name)
munit, Duration
duration) of
(Just (Rational -> Time
_, Name
name), WithUnit Time
time) -> do
Exp
timeE <- [|time|]
Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'toRelativeDuration) (Exp -> Type -> Exp
SigE (Name -> Exp
ConE 'Proxy) (Type -> Type -> Type
AppT (Name -> Type
ConT ''Proxy) (Name -> Type
ConT Name
name)))) Exp
timeE
(Just (Rational -> Time
constructor, Name
_), WithoutUnit Rational
time) ->
let time' :: Time
time' = Rational -> Time
constructor Rational
time
in [|toAbsoluteDuration time'|]
(Maybe (Rational -> Time, Name)
Nothing, WithUnit Time
time) -> [|toAbsoluteDuration time|]
(Maybe (Rational -> Time, Name)
Nothing, WithoutUnit Rational
_) -> String -> Q Exp
forall a. HasCallStack => String -> a
error String
"not defined"
where
catch :: Either t p -> (t -> p) -> p
catch (Left t
err) t -> p
f = t -> p
f t
err
catch (Right p
x) t -> p
_ = p
x
digits :: Int -> Maybe Int
digits :: Int -> Maybe Int
digits Int
n
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> (Int -> Int) -> Int -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> (Int -> String) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int
n
| Bool
otherwise = Maybe Int
forall a. Maybe a
Nothing
decimalP :: Parser Rational
decimalP :: Parser Rational
decimalP = do
Bool
isNegative <- Bool
-> ParsecT String () Identity Bool
-> ParsecT String () Identity Bool
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option Bool
False (ParsecT String () Identity Bool
-> ParsecT String () Identity Bool)
-> ParsecT String () Identity Bool
-> ParsecT String () Identity Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Char -> Bool
forall a b. a -> b -> a
const Bool
True (Char -> Bool)
-> ParsecT String () Identity Char
-> ParsecT String () Identity Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'-'
Integer
int <- String -> Integer
forall a. Read a => String -> a
read (String -> Integer)
-> ParsecT String () Identity String
-> ParsecT String () Identity Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option String
"0" (ParsecT String () Identity Char
-> ParsecT String () 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 () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit)
Int
frac <- Int
-> ParsecT String () Identity Int -> ParsecT String () Identity Int
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option Int
0 (ParsecT String () Identity Int -> ParsecT String () Identity Int)
-> ParsecT String () Identity Int -> ParsecT String () Identity Int
forall a b. (a -> b) -> a -> b
$ do
Char
_ <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.'
String
n <- ParsecT String () Identity Char
-> ParsecT String () 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 () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
Int -> ParsecT String () Identity Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> ParsecT String () Identity Int)
-> Int -> ParsecT String () Identity Int
forall a b. (a -> b) -> a -> b
$ String -> Int
forall a. Read a => String -> a
read String
n
let int' :: Rational
int' = Integer -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
int
frac' :: Rational
frac' = Int -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
frac
Rational -> Parser Rational
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rational -> Parser Rational)
-> (Rational -> Rational) -> Rational -> Parser Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rational -> Rational)
-> (Rational -> Rational) -> Bool -> Rational -> Rational
forall a. a -> a -> Bool -> a
bool Rational -> Rational
forall a. a -> a
id Rational -> Rational
forall a. Num a => a -> a
negate Bool
isNegative (Rational -> Parser Rational) -> Rational -> Parser Rational
forall a b. (a -> b) -> a -> b
$ case Int -> Maybe Int
digits Int
frac of
Maybe Int
Nothing -> Rational
int'
Just Int
n -> Rational
int' Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ (Rational
frac' Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
10Rational -> Int -> Rational
forall a b. (Num a, Integral b) => a -> b -> a
^Int
n)
withSuffix :: String -> Parser Rational
withSuffix :: String -> Parser Rational
withSuffix String
suffix = do
ParsecT String () Identity () -> ParsecT String () Identity ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
optional ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
Rational
decimal <- Parser Rational
decimalP
ParsecT String () Identity () -> ParsecT String () Identity ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
optional ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
String
_ <- String -> ParsecT String () Identity String
stringCI String
suffix
ParsecT String () Identity () -> ParsecT String () Identity ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
optional ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
ParsecT String () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
Rational -> Parser Rational
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rational
decimal
withSuffixes :: [String] -> Parser Rational
withSuffixes :: [String] -> Parser Rational
withSuffixes = [Parser Rational] -> Parser Rational
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice ([Parser Rational] -> Parser Rational)
-> ([String] -> [Parser Rational]) -> [String] -> Parser Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Parser Rational) -> [String] -> [Parser Rational]
forall a b. (a -> b) -> [a] -> [b]
map (Parser Rational -> Parser Rational
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (Parser Rational -> Parser Rational)
-> (String -> Parser Rational) -> String -> Parser Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Parser Rational
withSuffix)
stringCI :: String -> Parser String
stringCI :: String -> ParsecT String () Identity String
stringCI = (Char
-> ParsecT String () Identity String
-> ParsecT String () Identity String)
-> ParsecT String () Identity String
-> String
-> ParsecT String () Identity String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Char -> String -> String)
-> ParsecT String () Identity Char
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (:) (ParsecT String () Identity Char
-> ParsecT String () Identity String
-> ParsecT String () Identity String)
-> (Char -> ParsecT String () Identity Char)
-> Char
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ParsecT String () Identity Char
charCI) (ParsecT String () Identity String
-> String -> ParsecT String () Identity String)
-> ParsecT String () Identity String
-> String
-> ParsecT String () Identity String
forall a b. (a -> b) -> a -> b
$ String -> ParsecT String () Identity String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
""
where
charCI :: Char -> Parser Char
charCI :: Char -> ParsecT String () Identity Char
charCI Char
c
| Char -> Bool
isAlpha Char
c = Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char (Char -> Char
toUpper Char
c) ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char (Char -> Char
toLower Char
c)
| Bool
otherwise = Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
c
relativeP :: Parser Rational
relativeP :: Parser Rational
relativeP = String -> Parser Rational
withSuffix String
""
millisecondsP, secondsP, minutesP, hoursP, daysP, weeksP, yearsP :: Parser Time
millisecondsP :: Parser Time
millisecondsP = Rational -> Time
Millisec (Rational -> Time) -> Parser Rational -> Parser Time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> Parser Rational
withSuffixes [String
"ms", String
"msec", String
"msecs", String
"millisecond", String
"milliseconds"]
secondsP :: Parser Time
secondsP = Rational -> Time
Second (Rational -> Time) -> Parser Rational -> Parser Time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> Parser Rational
withSuffixes [String
"s", String
"sec", String
"secs", String
"second", String
"seconds"]
minutesP :: Parser Time
minutesP = Rational -> Time
Minute (Rational -> Time) -> Parser Rational -> Parser Time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> Parser Rational
withSuffixes [String
"m", String
"min", String
"mins", String
"minute", String
"minutes"]
hoursP :: Parser Time
hoursP = Rational -> Time
Hour (Rational -> Time) -> Parser Rational -> Parser Time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> Parser Rational
withSuffixes [String
"h", String
"hr", String
"hrs", String
"hour", String
"hours"]
daysP :: Parser Time
daysP = Rational -> Time
Day (Rational -> Time) -> Parser Rational -> Parser Time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> Parser Rational
withSuffixes [String
"d", String
"day", String
"days"]
weeksP :: Parser Time
weeksP = Rational -> Time
Week (Rational -> Time) -> Parser Rational -> Parser Time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> Parser Rational
withSuffixes [String
"w", String
"week", String
"weeks"]
yearsP :: Parser Time
yearsP = Rational -> Time
Year (Rational -> Time) -> Parser Rational -> Parser Time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> Parser Rational
withSuffixes [String
"y", String
"yr", String
"yrs", String
"year", String
"years"]
absoluteP :: Parser Time
absoluteP :: Parser Time
absoluteP = [Parser Time] -> Parser Time
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice ([Parser Time] -> Parser Time) -> [Parser Time] -> Parser Time
forall a b. (a -> b) -> a -> b
$ (Parser Time -> Parser Time) -> [Parser Time] -> [Parser Time]
forall a b. (a -> b) -> [a] -> [b]
map Parser Time -> Parser Time
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try [Parser Time]
parsers
where
parsers :: [Parser Time]
parsers =
[ Parser Time
millisecondsP
, Parser Time
secondsP
, Parser Time
minutesP
, Parser Time
hoursP
, Parser Time
daysP
, Parser Time
weeksP
, Parser Time
yearsP
]
data Duration
= WithoutUnit Rational
| WithUnit Time
durationP :: Parser Duration
durationP :: Parsec String () Duration
durationP = (Time -> Duration
WithUnit (Time -> Duration) -> Parser Time -> Parsec String () Duration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Time
absoluteP) Parsec String () Duration
-> Parsec String () Duration -> Parsec String () Duration
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Rational -> Duration
WithoutUnit (Rational -> Duration)
-> Parser Rational -> Parsec String () Duration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Rational
relativeP)