-- SPDX-FileCopyrightText: 2019 Serokell <https://serokell.io>
--
-- SPDX-License-Identifier: MPL-2.0

{-# LANGUAGE AllowAmbiguousTypes  #-}
{-# LANGUAGE CPP                  #-}
{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE InstanceSigs         #-}
{-# LANGUAGE Rank2Types           #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE UndecidableInstances #-}

-- | This module introduces function to format and parse time in desired way.

module Time.Series
       ( AllTimes
       , type (...)
         -- * Formatting
       , SeriesF (..)
       , unitsF

         -- * Parsing
       , 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)

-- $setup
-- >>> import Time.Units (Time (..), fortnight, hour, minute, ms, sec)
-- >>> import Time.Timestamp ((+:+))
-- >>> import GHC.Real ((%))



-- | Type-level list that consist of all times.
type AllTimes =
  '[ Fortnight, Week, Day, Hour, Minute, Second
   , Millisecond , Microsecond, Nanosecond, Picosecond
   ]

{- | Creates the list of time units in descending order by provided
the highest and the lowest bound of the desired list.
Throws the error when time units are not in the right order.

__Usage example:__

>>> seriesF @(Hour ... Second) $ hour 3 +:+ minute 5 +:+ sec 3 +:+ ms 123
"3h5m3+123/1000s"

-}
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"))

-- Drops wile not the required time unit in 'AllTimes'.
type family DropWhileNot (from :: Rat) (units :: [Rat]) :: [Rat] where
    DropWhileNot x '[] = '[]
    DropWhileNot x (u ': units) = If (u == x) (u ': units) (DropWhileNot x units)

-- Takes while not equal to the provided bound.
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 for verification of the descending order of the given
-- list of time 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  = ()  -- empty constraint; always satisfiable
    DescendingConstraint 'False = TypeError ('Text "List of units should be in descending order")

{- | Class for time formatting.

__Examples__

>>> seriesF @'[Day, Hour, Minute, Second] (minute 4000)
"2d18h40m"

>>> seriesF @'[Day, Minute, Second] (minute 4000)
"2d1120m"

>>> seriesF @'[Hour, Minute, Second] (sec 3601)
"1h1s"

>>>  seriesF @'[Hour, Second, Millisecond] (Time @Minute $ 3 % 2)
"90s"

>>> seriesF @'[Hour, Second] (minute 0)
"0h"

>>> seriesF @'[Hour, Minute, Second] (Time @Day (2 % 7))
"6h51m25+5/7s"

The received list should be in descending order. It would be verified at compile-time.
Example of the error from @ghci@:

>>> seriesF @'[Millisecond, Second] (minute 42)
...
    • List of units should be in descending order
    • In the expression: seriesF @'[Millisecond, Second] (minute 42)
      In an equation for ‘it’:
          it = seriesF @'[Millisecond, Second] (minute 42)
...

-}
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

{- | Similar to 'seriesF', but formats using all time units of the library.

>>> unitsF $ fortnight 5
"5fn"

>>> unitsF $ minute 4000
"2d18h40m"

-}
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 for time parsing.

Empty string on input will be parsed as 0 time of the required time unit:

>>> seriesP @'[Hour, Minute, Second] @Second ""
Just (0s)

__Examples__

>>> seriesP @'[Day, Hour, Minute, Second] @Minute "2d18h40m"
Just (4000m)

>>> seriesP @'[Day, Minute, Second] @Minute "2d1120m"
Just (4000m)

>>> seriesP @'[Hour, Minute, Second] @Second "1h1s"
Just (3601s)

>>> seriesP @'[Hour, Second, Millisecond] @Minute "90s"
Just (1+1/2m)

>>> seriesP @'[Hour, Second] @Second "11ns"
Nothing

>>> seriesP @'[Hour, Minute] @Minute "1+1/2h"
Nothing

>>> seriesP @'[Hour, Minute] @Minute "1+1/2m"
Just (1+1/2m)

>>> seriesP @'[Hour, Minute] @Minute "1h1+1/2m"
Just (61+1/2m)

__Note:__ The received list should be in descending order. It would be verified at compile-time.

-}
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)

{- | Similar to 'seriesP', but parses using all time units of the library.

>>> unitsP @Second "1m"
Just (60s)

>>> unitsP @Minute "2d18h40m"
Just (4000m)

-}
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

----------------------------------------------------------------------------
-- Util
----------------------------------------------------------------------------

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)