{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
#include "thyme.h"
module Data.Thyme.Format.Human
( humanTimeDiff
, humanTimeDiffs
, humanRelTime
, humanRelTimes
) where
import Prelude
import Control.Applicative
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)
{-# INLINE humanTimeDiff #-}
humanTimeDiff :: (TimeDiff d) => d -> String
humanTimeDiff :: d -> String
humanTimeDiff d :: d
d = d -> ShowS
forall d. TimeDiff d => d -> ShowS
humanTimeDiffs d
d ""
{-# ANN humanTimeDiffs "HLint: ignore Use fromMaybe" #-}
humanTimeDiffs :: (TimeDiff d) => d -> ShowS
humanTimeDiffs :: d -> ShowS
humanTimeDiffs td :: d
td = (if Int64
signed Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< 0 then (:) '-' 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
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 (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. [a] -> [a]
tail [Unit]
units) [Unit]
units
{-# INLINE humanRelTime #-}
humanRelTime :: UTCTime -> UTCTime -> String
humanRelTime :: UTCTime -> UTCTime -> String
humanRelTime ref :: UTCTime
ref time :: UTCTime
time = UTCTime -> UTCTime -> ShowS
humanRelTimes UTCTime
ref UTCTime
time ""
humanRelTimes :: UTCTime -> UTCTime -> ShowS
humanRelTimes :: UTCTime -> UTCTime -> ShowS
humanRelTimes ref :: UTCTime
ref time :: 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
(diff :: NominalDiffTime
diff, thence :: 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
LT -> (NominalDiffTime -> NominalDiffTime
forall v. AdditiveGroup v => v -> v
negateV NominalDiffTime
delta, (String -> ShowS
forall a. [a] -> [a] -> [a]
(++) "in " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.))
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]
(++) "right now")
GT -> (NominalDiffTime
delta, (ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. [a] -> [a] -> [a]
(++) " 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 us :: Micro
us next :: Micro
next Unit {..} = 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 (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 2)
inflection :: ShowS
inflection = if Int64
n Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== 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 1) (" microsecond" String -> ShowS
forall a. [a] -> [a] -> [a]
++) (" microseconds" String -> ShowS
forall a. [a] -> [a] -> [a]
++))
[ String -> Rational -> Unit -> Unit
times "millisecond" 1000
, String -> Rational -> Unit -> Unit
times "second" 1000
, String -> Rational -> Unit -> Unit
times "minute" 60
, String -> Rational -> Unit -> Unit
times "hour" 60
, String -> Rational -> Unit -> Unit
times "day" 24
, String -> Rational -> Unit -> Unit
times "week" 7
, String -> Rational -> Unit -> Unit
times "month" (30.4368 Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ 7)
, String -> Rational -> Unit -> Unit
times "year" 12
, String -> Rational -> Unit -> Unit
times "decade" 10
, String -> Rational -> Unit -> Unit
times "century" 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 Unit ShowS ShowS
_plural (" centuries" String -> ShowS
forall a. [a] -> [a] -> [a]
++)
, String -> Rational -> Unit -> Unit
times "millennium" 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 Unit ShowS ShowS
_plural (" 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)
] 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
. (:) ' ' -> ShowS
single) r :: Rational
r Unit {Micro
unit :: Micro
unit :: Unit -> Micro
unit}
= Unit :: Micro -> ShowS -> ShowS -> 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
. (:) 's', ..}