{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Time.Series
( AllTimes
, type (...)
, SeriesF (..)
, unitsF
, SeriesP (..)
, unitsP
) where
import Data.Char (isDigit, isLetter)
import Data.Kind (Constraint)
import Data.Type.Bool (type (&&), If)
import Data.Type.Equality (type (==))
import GHC.TypeLits (ErrorMessage (Text), TypeError)
import Text.Read (readMaybe)
import Time.Rational (type (>=%), withRuntimeDivRat)
import Time.Rational (Rat)
import Time.Timestamp ((-:-))
import Time.Units (Day, Fortnight, Hour, KnownRatName, Microsecond, Millisecond, Minute, Nanosecond,
Picosecond, Second, Time (..), Week, floorUnit, toUnit)
type AllTimes =
'[ Fortnight, Week, Day, Hour, Minute, Second
, Millisecond , Microsecond, Nanosecond, Picosecond
]
type family (from :: Rat) ... (to :: Rat) :: [Rat] where
from ... to = If (IsDescending '[from, to])
(TakeWhileNot to (DropWhileNot from AllTimes))
(TypeError ('Text "Units should be in descending order"))
type family DropWhileNot (from :: Rat) (units :: [Rat]) :: [Rat] where
DropWhileNot x '[] = '[]
DropWhileNot x (u ': units) = If (u == x) (u ': units) (DropWhileNot x units)
type family TakeWhileNot (to :: Rat) (units :: [Rat]) :: [Rat] where
TakeWhileNot x '[] = '[]
TakeWhileNot x (u ': units) = If (u == x) '[u] (u ': TakeWhileNot x units)
type family IsDescending (units :: [Rat]) :: Bool where
IsDescending ('[]) = 'True
IsDescending ('[unit]) = 'True
IsDescending (unit1 ': unit2 ': units) =
(unit1 >=% unit2) && (IsDescending (unit2 ': units))
type family DescendingConstraint (b :: Bool) :: Constraint where
DescendingConstraint 'True = ()
DescendingConstraint 'False = TypeError ('Text "List of units should be in descending order")
class SeriesF (units :: [Rat]) where
seriesF :: forall (someUnit :: Rat) . KnownRatName someUnit
=> Time someUnit
-> String
instance SeriesF ('[] :: [Rat]) where
seriesF :: Time someUnit -> String
seriesF :: forall (someUnit :: Rat). Time someUnit -> String
seriesF Time someUnit
_ = String
""
instance (KnownRatName unit) => SeriesF ('[unit] :: [Rat]) where
seriesF :: forall (someUnit :: Rat) . KnownRatName someUnit
=> Time someUnit -> String
seriesF :: forall (someUnit :: Rat).
KnownRatName someUnit =>
Time someUnit -> String
seriesF Time someUnit
t =
let newTime :: Time unit
newTime = forall (a :: Rat) (b :: Rat) r.
(KnownRat a, KnownRat b) =>
(KnownRat (a / b) => r) -> r
withRuntimeDivRat @someUnit @unit forall a b. (a -> b) -> a -> b
$ forall (unitTo :: Rat) (unitFrom :: Rat).
KnownDivRat unitFrom unitTo =>
Time unitFrom -> Time unitTo
toUnit @unit Time someUnit
t
in forall a. Show a => a -> String
show Time unit
newTime
instance ( KnownRatName unit
, SeriesF (nextUnit : units)
, DescendingConstraint (IsDescending (unit ': nextUnit ': units))
)
=> SeriesF (unit ': nextUnit ': units :: [Rat]) where
seriesF :: forall (someUnit :: Rat) . KnownRatName someUnit
=> Time someUnit -> String
seriesF :: forall (someUnit :: Rat).
KnownRatName someUnit =>
Time someUnit -> String
seriesF Time someUnit
t = let newUnit :: Time unit
newUnit = forall (a :: Rat) (b :: Rat) r.
(KnownRat a, KnownRat b) =>
(KnownRat (a / b) => r) -> r
withRuntimeDivRat @someUnit @unit forall a b. (a -> b) -> a -> b
$ forall (unitTo :: Rat) (unitFrom :: Rat).
KnownDivRat unitFrom unitTo =>
Time unitFrom -> Time unitTo
toUnit @unit Time someUnit
t
flooredNewUnit :: Time unit
flooredNewUnit = forall (unit :: Rat). Time unit -> Time unit
floorUnit Time unit
newUnit
timeStr :: String
timeStr = case Time unit
flooredNewUnit of
Time RatioNat
0 -> String
""
Time unit
_ -> forall a. Show a => a -> String
show Time unit
flooredNewUnit
nextUnit :: Time unit
nextUnit = forall (a :: Rat) (b :: Rat) r.
(KnownRat a, KnownRat b) =>
(KnownRat (a / b) => r) -> r
withRuntimeDivRat @unit @unit forall a b. (a -> b) -> a -> b
$ Time unit
newUnit forall (unitResult :: Rat) (unitLeft :: Rat).
KnownDivRat unitLeft unitResult =>
Time unitLeft -> Time unitResult -> Time unitResult
-:- Time unit
flooredNewUnit
in if Time unit
nextUnit forall a. Eq a => a -> a -> Bool
== forall (rat :: Rat). RatioNat -> Time rat
Time RatioNat
0
then forall a. Show a => a -> String
show Time unit
newUnit
else String
timeStr forall a. [a] -> [a] -> [a]
++ forall (units :: [Rat]) (someUnit :: Rat).
(SeriesF units, KnownRatName someUnit) =>
Time someUnit -> String
seriesF @(nextUnit ': units) @unit Time unit
nextUnit
unitsF :: forall unit . KnownRatName unit => Time unit -> String
unitsF :: forall (someUnit :: Rat).
KnownRatName someUnit =>
Time someUnit -> String
unitsF = forall (units :: [Rat]) (someUnit :: Rat).
(SeriesF units, KnownRatName someUnit) =>
Time someUnit -> String
seriesF @AllTimes
class SeriesP (units :: [Rat]) where
seriesP :: forall (someUnit :: Rat) . KnownRatName someUnit
=> String -> Maybe (Time someUnit)
instance SeriesP '[] where
seriesP :: forall (someUnit :: Rat).
KnownRatName someUnit =>
String -> Maybe (Time someUnit)
seriesP String
_ = forall a. Maybe a
Nothing
instance (KnownRatName unit) => SeriesP '[unit] where
seriesP :: forall (someUnit :: Rat) . KnownRatName someUnit
=> String -> Maybe (Time someUnit)
seriesP :: forall (someUnit :: Rat).
KnownRatName someUnit =>
String -> Maybe (Time someUnit)
seriesP String
"" = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (rat :: Rat). RatioNat -> Time rat
Time RatioNat
0
seriesP String
str = forall (unit :: Rat) (someUnit :: Rat).
(KnownRatName unit, KnownRatName someUnit) =>
String -> Maybe (Time someUnit)
readMaybeTime @unit String
str
instance ( KnownRatName unit
, SeriesP (nextUnit : units)
, DescendingConstraint (IsDescending (unit ': nextUnit ': units))
)
=> SeriesP (unit ': nextUnit ': units :: [Rat]) where
seriesP :: forall (someUnit :: Rat) . KnownRatName someUnit
=> String -> Maybe (Time someUnit)
seriesP :: forall (someUnit :: Rat).
KnownRatName someUnit =>
String -> Maybe (Time someUnit)
seriesP String
"" = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (rat :: Rat). RatioNat -> Time rat
Time RatioNat
0
seriesP String
str = let (String
num, String
rest) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit String
str
(String
u, String
nextStr) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isLetter String
rest
maybeT :: Maybe (Time someUnit)
maybeT = forall (unit :: Rat) (someUnit :: Rat).
(KnownRatName unit, KnownRatName someUnit) =>
String -> Maybe (Time someUnit)
readMaybeTime @unit forall a b. (a -> b) -> a -> b
$ String
num forall a. [a] -> [a] -> [a]
++ String
u
in case Maybe (Time someUnit)
maybeT of
Maybe (Time someUnit)
Nothing -> forall (units :: [Rat]) (someUnit :: Rat).
(SeriesP units, KnownRatName someUnit) =>
String -> Maybe (Time someUnit)
seriesP @(nextUnit ': units) String
str
Just Time someUnit
t -> ((Time someUnit
t forall a. Semigroup a => a -> a -> a
<>)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (units :: [Rat]) (someUnit :: Rat).
(SeriesP units, KnownRatName someUnit) =>
String -> Maybe (Time someUnit)
seriesP @(nextUnit ': units) String
nextStr)
unitsP :: forall unit . KnownRatName unit => String -> Maybe (Time unit)
unitsP :: forall (someUnit :: Rat).
KnownRatName someUnit =>
String -> Maybe (Time someUnit)
unitsP = forall (units :: [Rat]) (someUnit :: Rat).
(SeriesP units, KnownRatName someUnit) =>
String -> Maybe (Time someUnit)
seriesP @AllTimes @unit
readMaybeTime :: forall (unit :: Rat) (someUnit :: Rat) . (KnownRatName unit, KnownRatName someUnit)
=> String -> Maybe (Time someUnit)
readMaybeTime :: forall (unit :: Rat) (someUnit :: Rat).
(KnownRatName unit, KnownRatName someUnit) =>
String -> Maybe (Time someUnit)
readMaybeTime String
str =
forall (a :: Rat) (b :: Rat) r.
(KnownRat a, KnownRat b) =>
(KnownRat (a / b) => r) -> r
withRuntimeDivRat @unit @someUnit forall a b. (a -> b) -> a -> b
$
forall (unitTo :: Rat) (unitFrom :: Rat).
KnownDivRat unitFrom unitTo =>
Time unitFrom -> Time unitTo
toUnit @someUnit forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Read a => String -> Maybe a
readMaybe @(Time unit) String
str)