{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}

#include "thyme.h"
#if HLINT
#include "cabal_macros.h"
#endif

-- | Vague textual descriptions of time durations.
module Data.Thyme.Format.Human
    ( humanTimeDiff
    , humanTimeDiffs
    , humanRelTime
    , humanRelTimes
    ) where

import Prelude
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
import Control.Arrow
import Control.Lens
import Control.Monad
import Data.AdditiveGroup
import Data.AffineSpace
import Data.Foldable
import Data.Thyme.Internal.Micro
import Data.Monoid
import Data.Thyme.Clock.Internal
import Data.VectorSpace

data Unit = Unit
    { Unit -> Micro
unit :: Micro
    , Unit -> ShowS
single :: ShowS
    , Unit -> ShowS
plural :: ShowS
    }
LENS(Unit,plural,ShowS)

-- | Display 'DiffTime' or 'NominalDiffTime' in a human-readable form.
{-# INLINE humanTimeDiff #-}
humanTimeDiff :: (TimeDiff d) => d -> String
humanTimeDiff :: forall d. TimeDiff d => d -> String
humanTimeDiff d
d = d -> ShowS
forall d. TimeDiff d => d -> ShowS
humanTimeDiffs d
d String
""

-- | Display 'DiffTime' or 'NominalDiffTime' in a human-readable form.
{-# ANN humanTimeDiffs "HLint: ignore Use fromMaybe" #-}
humanTimeDiffs :: (TimeDiff d) => d -> ShowS
humanTimeDiffs :: forall d. TimeDiff d => d -> ShowS
humanTimeDiffs d
td = (if Int64
signed Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
0 then (:) Char
'-' else ShowS
forall a. a -> a
id) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
diff where
    signed :: Int64
signed@(Int64 -> Micro
Micro (Int64 -> Micro) -> (Int64 -> Int64) -> Int64 -> Micro
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Int64
forall a. Num a => a -> a
abs -> Micro
us) = d
td d -> Getting Int64 d Int64 -> Int64
forall s a. s -> Getting a s a -> a
^. Getting Int64 d Int64
forall t. TimeDiff t => Iso' t Int64
Iso' d Int64
microseconds
    diff :: ShowS
diff = ShowS -> (ShowS -> ShowS) -> Maybe ShowS -> ShowS
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ShowS
forall a. a -> a
id ShowS -> ShowS
forall a. a -> a
id (Maybe ShowS -> ShowS)
-> ([First ShowS] -> Maybe ShowS) -> [First ShowS] -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. First ShowS -> Maybe ShowS
forall a. First a -> Maybe a
getFirst (First ShowS -> Maybe ShowS)
-> ([First ShowS] -> First ShowS) -> [First ShowS] -> Maybe ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [First ShowS] -> First ShowS
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([First ShowS] -> ShowS) -> [First ShowS] -> ShowS
forall a b. (a -> b) -> a -> b
$
        (Unit -> Unit -> First ShowS) -> [Unit] -> [Unit] -> [First ShowS]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Micro -> Micro -> Unit -> First ShowS
approx Micro
us (Micro -> Unit -> First ShowS)
-> (Unit -> Micro) -> Unit -> Unit -> First ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unit -> Micro
unit) ([Unit] -> [Unit]
forall a. HasCallStack => [a] -> [a]
tail [Unit]
units) [Unit]
units

-- | Display one 'UTCTime' relative to another, in a human-readable form.
{-# INLINE humanRelTime #-}
humanRelTime :: UTCTime -> UTCTime -> String
humanRelTime :: UTCTime -> UTCTime -> String
humanRelTime UTCTime
ref UTCTime
time = UTCTime -> UTCTime -> ShowS
humanRelTimes UTCTime
ref UTCTime
time String
""

-- | Display one 'UTCTime' relative to another, in a human-readable form.
humanRelTimes :: UTCTime -> UTCTime -> ShowS
humanRelTimes :: UTCTime -> UTCTime -> ShowS
humanRelTimes UTCTime
ref UTCTime
time = ShowS -> ShowS
thence (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> ShowS
forall d. TimeDiff d => d -> ShowS
humanTimeDiffs NominalDiffTime
diff where
    (NominalDiffTime
diff, ShowS -> ShowS
thence) = case NominalDiffTime -> NominalDiffTime -> Ordering
forall a. Ord a => a -> a -> Ordering
compare NominalDiffTime
delta NominalDiffTime
forall v. AdditiveGroup v => v
zeroV of
        Ordering
LT -> (NominalDiffTime -> NominalDiffTime
forall v. AdditiveGroup v => v -> v
negateV NominalDiffTime
delta, (String -> ShowS
forall a. [a] -> [a] -> [a]
(++) String
"in " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.))
        Ordering
EQ -> (NominalDiffTime
forall v. AdditiveGroup v => v
zeroV, ShowS -> ShowS -> ShowS
forall a b. a -> b -> a
const (ShowS -> ShowS -> ShowS) -> ShowS -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
forall a. [a] -> [a] -> [a]
(++) String
"right now")
        Ordering
GT -> (NominalDiffTime
delta, (ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. [a] -> [a] -> [a]
(++) String
" ago"))
        where delta :: Diff UTCTime
delta = UTCTime
time UTCTime -> UTCTime -> Diff UTCTime
forall p. AffineSpace p => p -> p -> Diff p
.-. UTCTime
ref

approx :: Micro -> Micro -> Unit -> First ShowS
approx :: Micro -> Micro -> Unit -> First ShowS
approx Micro
us Micro
next Unit {Micro
ShowS
unit :: Unit -> Micro
single :: Unit -> ShowS
plural :: Unit -> ShowS
unit :: Micro
single :: ShowS
plural :: ShowS
..} = Maybe ShowS -> First ShowS
forall a. Maybe a -> First a
First (Maybe ShowS -> First ShowS) -> Maybe ShowS -> First ShowS
forall a b. (a -> b) -> a -> b
$
        Int64 -> ShowS
forall a. Show a => a -> ShowS
shows Int64
n ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
inflection ShowS -> Maybe () -> Maybe ShowS
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Micro
us Micro -> Micro -> Bool
forall a. Ord a => a -> a -> Bool
< Micro
next) where
    n :: Int64
n = (Int64, Micro) -> Int64
forall a b. (a, b) -> a
fst ((Int64, Micro) -> Int64) -> (Int64, Micro) -> Int64
forall a b. (a -> b) -> a -> b
$ Micro -> Micro -> (Int64, Micro)
microQuotRem (Micro
us Micro -> Micro -> Micro
forall v. AdditiveGroup v => v -> v -> v
^+^ Micro
half) Micro
unit where
        half :: Micro
half = Int64 -> Micro
Micro (Int64 -> Micro)
-> ((Int64, Micro) -> Int64) -> (Int64, Micro) -> Micro
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int64, Micro) -> Int64
forall a b. (a, b) -> a
fst ((Int64, Micro) -> Micro) -> (Int64, Micro) -> Micro
forall a b. (a -> b) -> a -> b
$ Micro -> Micro -> (Int64, Micro)
microQuotRem Micro
unit (Int64 -> Micro
Micro Int64
2)
    inflection :: ShowS
inflection = if Int64
n Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
1 then ShowS
single else ShowS
plural

units :: [Unit]
units :: [Unit]
units = (Unit -> (Unit -> Unit) -> Unit)
-> Unit -> [Unit -> Unit] -> [Unit]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Unit -> (Unit -> Unit) -> Unit
forall a b. a -> (a -> b) -> b
(&)
    (Micro -> ShowS -> ShowS -> Unit
Unit (Int64 -> Micro
Micro Int64
1) (String
" microsecond" String -> ShowS
forall a. [a] -> [a] -> [a]
++) (String
" microseconds" String -> ShowS
forall a. [a] -> [a] -> [a]
++))
    [ String -> Rational -> Unit -> Unit
times String
"millisecond"   Rational
1000
    , String -> Rational -> Unit -> Unit
times String
"second"        Rational
1000
    , String -> Rational -> Unit -> Unit
times String
"minute"        Rational
60
    , String -> Rational -> Unit -> Unit
times String
"hour"          Rational
60
    , String -> Rational -> Unit -> Unit
times String
"day"           Rational
24
    , String -> Rational -> Unit -> Unit
times String
"week"          Rational
7
    , String -> Rational -> Unit -> Unit
times String
"month"         (Rational
30.4368 Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
7)
    , String -> Rational -> Unit -> Unit
times String
"year"          Rational
12
    , String -> Rational -> Unit -> Unit
times String
"decade"        Rational
10
    , String -> Rational -> Unit -> Unit
times String
"century"       Rational
10 (Unit -> Unit) -> (Unit -> Unit) -> Unit -> Unit
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Setter Unit Unit ShowS ShowS -> ShowS -> Unit -> Unit
forall s t a b. Setter s t a b -> b -> s -> t
set Setter Unit Unit ShowS ShowS
Lens' Unit ShowS
_plural (String
" centuries" String -> ShowS
forall a. [a] -> [a] -> [a]
++)
    , String -> Rational -> Unit -> Unit
times String
"millennium"    Rational
10 (Unit -> Unit) -> (Unit -> Unit) -> Unit -> Unit
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Setter Unit Unit ShowS ShowS -> ShowS -> Unit -> Unit
forall s t a b. Setter s t a b -> b -> s -> t
set Setter Unit Unit ShowS ShowS
Lens' Unit ShowS
_plural (String
" millennia" String -> ShowS
forall a. [a] -> [a] -> [a]
++)
    , Unit -> Unit -> Unit
forall a b. a -> b -> a
const (Micro -> ShowS -> ShowS -> Unit
Unit Micro
forall a. Bounded a => a
maxBound ShowS
forall a. a -> a
id ShowS
forall a. a -> a
id) -- upper bound needed for humanTimeDiffs.diff
    ] where
    times :: String -> Rational -> Unit -> Unit
    times :: String -> Rational -> Unit -> Unit
times (String -> ShowS
forall a. [a] -> [a] -> [a]
(++) (String -> ShowS) -> ShowS -> String -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) Char
' ' -> ShowS
single) Rational
r Unit {Micro
unit :: Unit -> Micro
unit :: Micro
unit}
        = Unit {unit :: Micro
unit = Rational
Scalar Micro
r Scalar Micro -> Micro -> Micro
forall v. VectorSpace v => Scalar v -> v -> v
*^ Micro
unit, plural :: ShowS
plural = ShowS
single ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) Char
's', ShowS
single :: ShowS
single :: ShowS
..}