{-# LANGUAGE TemplateHaskell #-}

{-|
Copyright   : (c) Ryota Kameoka, 2018
License     : BSD-3
Maintainer  : kameoka.ryota@gmail.com
Stability   : experimental

All quasiquoters defined in this module are re-exported from @Data.Time.Clock.Duration@.
-}

module Data.Time.Clock.Duration.QQ
    (
    -- * Quasiquoters
      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)

-- $setup
-- >>> :set -XQuasiQuotes
-- >>> import Data.Time.Clock (DiffTime, NominalDiffTime)
-- >>> import Foreign.C.Types (CSUSeconds, CUSeconds)

-- | A quasiquoter to denote a duration.
--
-- >>> [t| 42s |] :: DiffTime
-- 42s
--
-- >>> [t| 1day |] :: DiffTime
-- 86400s
--
-- The expression has the type of @'AbsoluteDuration' a => a@.
--
-- >>> [t| 1ms |] :: NominalDiffTime
-- 0.001s
--
-- >>> [t| 1ms |] :: CSUSeconds
-- 1000
--
-- >>> [t| 1ms |] :: CUSeconds
-- 1000
--
-- You can use various expressions inside the quasiquoter. (See 'Data.Time.Clock.Duration.Types.Time' for details.)
--
-- >>> [t| 1ms |] :: DiffTime
-- 0.001s
--
-- >>> [t| 1s |] :: DiffTime
-- 1s
--
-- >>> [t| 1m |] :: DiffTime
-- 60s
--
-- >>> [t| 1h |] :: DiffTime
-- 3600s
--
-- >>> [t| 1d |] :: DiffTime
-- 86400s
--
-- >>> [t| 1w |] :: DiffTime
-- 604800s
--
-- >>> [t| 1y |] :: DiffTime
-- 31536000s
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 }

-- | A quasiquoter to denote a duration in seconds. Its behavior varies according to what you give
-- to the quasiquoter.
--
-- When a unitless number (like @42@) is supplied to 's', the expression has the type of @'AbsoluteDuration' a => a@.
--
-- >>> [s| 42 |] :: DiffTime
-- 42s
--
-- When you pass a string with a number and a valid unit (like @42s@), the expression has the type of
-- @'RelativeDuration' a => a@, and it represents how long the given duration is in seconds.
--
-- For example, how long is 42 minutes in seconds?
--
-- >>> [s| 42m |] :: Int
-- 2520
--
-- Note that short durations can be rounded to zero when treated as an integer.
--
-- >>> [s| 1ms |] :: Int
-- 0
-- >>> [s| 1ms |] :: Integer
-- 0
--
-- To avoid this, use 'Data.Ratio.Ratio' or 'Prelude.Float' instead.
--
-- >>> [s| 1ms |] :: Rational
-- 1 % 1000
-- >>> [s| 1ms |] :: Float
-- 1.0e-3
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)) }

-- | A quasiquoter to denote a duration in milliseconds. See 's' for detailed usage.
--
-- >>> [ms| 42 |] :: DiffTime
-- 0.042s
--
-- >>> [ms| 42s |] :: Integer
-- 42000
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)) }

-- | A quasiquoter to denote a duration in microseconds. See 's' for detailed usage.
--
-- >>> [µs| 42 |] :: DiffTime
-- 0.000042s
--
-- >>> [µs| 42s |] :: Integer
-- 42000000
µ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)) }

-- | A quasiquoter to denote a duration in nanoseconds. See 's' for detailed usage.
--
-- >>> [ns| 42 |] :: DiffTime
-- 0.000000042s
--
-- >>> [ns| 42s |] :: Integer
-- 42000000000
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)) }

-- | A quasiquoter to denote a duration in picoseconds. See 's' for detailed usage.
--
-- >>> [ps| 42 |] :: DiffTime
-- 0.000000000042s
--
-- >>> [ps| 42s |] :: Integer
-- 42000000000000
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
        -- [s| 42m |]
        (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
        -- [s| 42 |]
        (Just (Rational -> Time
constructor, Name
_), WithoutUnit Rational
time) ->
           let time' :: Time
time' = Rational -> Time
constructor Rational
time
            in [|toAbsoluteDuration time'|]
        -- [t| 42m |]
        (Maybe (Rational -> Time, Name)
Nothing, WithUnit Time
time) -> [|toAbsoluteDuration time|]
        -- [t| 42 |]
        (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"]

-- | The underlying 'parsec' parser.
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)