module Data.Timeframe (
  Timeframe,
  module Data.Interval,
  localTimeframeAt,
  localTimeframe,
  pureLocalTimeframe,
  duration,
  Event,
  event,
  Calendar (..),
  singleton,
  calendar,
  addEvent,
  totalDuration,
) where

import Data.Interval
import Data.Interval.Layers (Layers)
import Data.Interval.Layers qualified as Layers
import Data.Map.Strict qualified as Map
import Data.Time.Compat
import GHC.IO (unsafePerformIO)

-- | > type Timeframe = Interval UTCTime
type Timeframe = Interval UTCTime

localTimeframeAt :: TimeZone -> LocalTime -> LocalTime -> Timeframe
localTimeframeAt :: TimeZone -> LocalTime -> LocalTime -> Timeframe
localTimeframeAt = (UTCTime -> UTCTime -> Timeframe)
-> (LocalTime -> UTCTime) -> LocalTime -> LocalTime -> Timeframe
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on UTCTime -> UTCTime -> Timeframe
forall x. Ord x => x -> x -> Interval x
(:||:) ((LocalTime -> UTCTime) -> LocalTime -> LocalTime -> Timeframe)
-> (TimeZone -> LocalTime -> UTCTime)
-> TimeZone
-> LocalTime
-> LocalTime
-> Timeframe
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeZone -> LocalTime -> UTCTime
localTimeToUTC

localTimeframe :: (MonadIO io) => LocalTime -> LocalTime -> io Timeframe
localTimeframe :: LocalTime -> LocalTime -> io Timeframe
localTimeframe LocalTime
t1 LocalTime
t2 =
  IO TimeZone -> io TimeZone
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO TimeZone
getCurrentTimeZone io TimeZone -> (TimeZone -> Timeframe) -> io Timeframe
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \TimeZone
tz -> TimeZone -> LocalTime -> LocalTime -> Timeframe
localTimeframeAt TimeZone
tz LocalTime
t1 LocalTime
t2

pureLocalTimeframe :: LocalTime -> LocalTime -> Timeframe
pureLocalTimeframe :: LocalTime -> LocalTime -> Timeframe
pureLocalTimeframe LocalTime
t1 LocalTime
t2 =
  let tz :: TimeZone
tz = IO TimeZone -> TimeZone
forall a. IO a -> a
unsafePerformIO IO TimeZone
getCurrentTimeZone
   in TimeZone -> LocalTime -> LocalTime -> Timeframe
localTimeframeAt TimeZone
tz LocalTime
t1 LocalTime
t2

duration :: Timeframe -> Maybe NominalDiffTime
duration :: Timeframe -> Maybe NominalDiffTime
duration = (UTCTime -> UTCTime -> NominalDiffTime)
-> Timeframe -> Maybe NominalDiffTime
forall y x.
(Ord x, Num y) =>
(x -> x -> y) -> Interval x -> Maybe y
measuring UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime

-- | An 'Event' is something that happens for a period of time.
--
-- > type Event n = Layers UTCTime (Sum n)
type Event n = Layers UTCTime (Sum n)

event :: (Num n) => Timeframe -> Event n
event :: Timeframe -> Event n
event = (Timeframe -> Sum n -> Event n
forall x y. Ord x => Interval x -> y -> Layers x y
`Layers.singleton` Sum n
1)

newtype Calendar ev n = Calendar {Calendar ev n -> Map ev (Event n)
getCalendar :: Map ev (Event n)}
  deriving (Calendar ev n -> Calendar ev n -> Bool
(Calendar ev n -> Calendar ev n -> Bool)
-> (Calendar ev n -> Calendar ev n -> Bool) -> Eq (Calendar ev n)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall ev n.
(Eq ev, Eq n) =>
Calendar ev n -> Calendar ev n -> Bool
/= :: Calendar ev n -> Calendar ev n -> Bool
$c/= :: forall ev n.
(Eq ev, Eq n) =>
Calendar ev n -> Calendar ev n -> Bool
== :: Calendar ev n -> Calendar ev n -> Bool
$c== :: forall ev n.
(Eq ev, Eq n) =>
Calendar ev n -> Calendar ev n -> Bool
Eq, Eq (Calendar ev n)
Eq (Calendar ev n)
-> (Calendar ev n -> Calendar ev n -> Ordering)
-> (Calendar ev n -> Calendar ev n -> Bool)
-> (Calendar ev n -> Calendar ev n -> Bool)
-> (Calendar ev n -> Calendar ev n -> Bool)
-> (Calendar ev n -> Calendar ev n -> Bool)
-> (Calendar ev n -> Calendar ev n -> Calendar ev n)
-> (Calendar ev n -> Calendar ev n -> Calendar ev n)
-> Ord (Calendar ev n)
Calendar ev n -> Calendar ev n -> Bool
Calendar ev n -> Calendar ev n -> Ordering
Calendar ev n -> Calendar ev n -> Calendar ev n
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall ev n. (Ord ev, Ord n) => Eq (Calendar ev n)
forall ev n.
(Ord ev, Ord n) =>
Calendar ev n -> Calendar ev n -> Bool
forall ev n.
(Ord ev, Ord n) =>
Calendar ev n -> Calendar ev n -> Ordering
forall ev n.
(Ord ev, Ord n) =>
Calendar ev n -> Calendar ev n -> Calendar ev n
min :: Calendar ev n -> Calendar ev n -> Calendar ev n
$cmin :: forall ev n.
(Ord ev, Ord n) =>
Calendar ev n -> Calendar ev n -> Calendar ev n
max :: Calendar ev n -> Calendar ev n -> Calendar ev n
$cmax :: forall ev n.
(Ord ev, Ord n) =>
Calendar ev n -> Calendar ev n -> Calendar ev n
>= :: Calendar ev n -> Calendar ev n -> Bool
$c>= :: forall ev n.
(Ord ev, Ord n) =>
Calendar ev n -> Calendar ev n -> Bool
> :: Calendar ev n -> Calendar ev n -> Bool
$c> :: forall ev n.
(Ord ev, Ord n) =>
Calendar ev n -> Calendar ev n -> Bool
<= :: Calendar ev n -> Calendar ev n -> Bool
$c<= :: forall ev n.
(Ord ev, Ord n) =>
Calendar ev n -> Calendar ev n -> Bool
< :: Calendar ev n -> Calendar ev n -> Bool
$c< :: forall ev n.
(Ord ev, Ord n) =>
Calendar ev n -> Calendar ev n -> Bool
compare :: Calendar ev n -> Calendar ev n -> Ordering
$ccompare :: forall ev n.
(Ord ev, Ord n) =>
Calendar ev n -> Calendar ev n -> Ordering
$cp1Ord :: forall ev n. (Ord ev, Ord n) => Eq (Calendar ev n)
Ord, Int -> Calendar ev n -> ShowS
[Calendar ev n] -> ShowS
Calendar ev n -> String
(Int -> Calendar ev n -> ShowS)
-> (Calendar ev n -> String)
-> ([Calendar ev n] -> ShowS)
-> Show (Calendar ev n)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall ev n. (Show ev, Show n) => Int -> Calendar ev n -> ShowS
forall ev n. (Show ev, Show n) => [Calendar ev n] -> ShowS
forall ev n. (Show ev, Show n) => Calendar ev n -> String
showList :: [Calendar ev n] -> ShowS
$cshowList :: forall ev n. (Show ev, Show n) => [Calendar ev n] -> ShowS
show :: Calendar ev n -> String
$cshow :: forall ev n. (Show ev, Show n) => Calendar ev n -> String
showsPrec :: Int -> Calendar ev n -> ShowS
$cshowsPrec :: forall ev n. (Show ev, Show n) => Int -> Calendar ev n -> ShowS
Show, Typeable)

instance (Ord ev, Num n) => Semigroup (Calendar ev n) where
  Calendar Map ev (Event n)
a <> :: Calendar ev n -> Calendar ev n -> Calendar ev n
<> Calendar Map ev (Event n)
b = Map ev (Event n) -> Calendar ev n
forall ev n. Map ev (Event n) -> Calendar ev n
Calendar ((Event n -> Event n -> Event n)
-> Map ev (Event n) -> Map ev (Event n) -> Map ev (Event n)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Event n -> Event n -> Event n
forall a. Semigroup a => a -> a -> a
(<>) Map ev (Event n)
a Map ev (Event n)
b)

instance (Ord ev, Num n) => Monoid (Calendar ev n) where
  mempty :: Calendar ev n
mempty = Map ev (Event n) -> Calendar ev n
forall ev n. Map ev (Event n) -> Calendar ev n
Calendar Map ev (Event n)
forall a. Monoid a => a
mempty

singleton :: (Ord ev, Num n) => ev -> Event n -> Calendar ev n
singleton :: ev -> Event n -> Calendar ev n
singleton ev
ev Event n
cvg = Map ev (Event n) -> Calendar ev n
forall ev n. Map ev (Event n) -> Calendar ev n
Calendar (ev -> Event n -> Map ev (Event n)
forall k a. k -> a -> Map k a
Map.singleton ev
ev Event n
cvg)

calendar :: (Ord ev, Num n) => ev -> Timeframe -> Calendar ev n
calendar :: ev -> Timeframe -> Calendar ev n
calendar ev
ev Timeframe
tf = ev -> Event n -> Calendar ev n
forall ev n. (Ord ev, Num n) => ev -> Event n -> Calendar ev n
singleton ev
ev (Timeframe -> Sum n -> Event n
forall x y. Ord x => Interval x -> y -> Layers x y
Layers.singleton Timeframe
tf Sum n
1)

addEvent :: (Ord ev, Num n) => ev -> Event n -> Calendar ev n -> Calendar ev n
addEvent :: ev -> Event n -> Calendar ev n -> Calendar ev n
addEvent ev
ev Event n
cvg (Calendar Map ev (Event n)
c) = Map ev (Event n) -> Calendar ev n
forall ev n. Map ev (Event n) -> Calendar ev n
Calendar ((Event n -> Event n -> Event n)
-> ev -> Event n -> Map ev (Event n) -> Map ev (Event n)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Event n -> Event n -> Event n
forall a. Semigroup a => a -> a -> a
(<>) ev
ev Event n
cvg Map ev (Event n)
c)

totalDuration :: forall ev n. (Ord ev, Real n) => ev -> Calendar ev n -> Maybe NominalDiffTime
totalDuration :: ev -> Calendar ev n -> Maybe NominalDiffTime
totalDuration ev
ev (Calendar Map ev (Event n)
c) = case Map ev (Event n)
c Map ev (Event n) -> ev -> Maybe (Event n)
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? ev
ev of
  Maybe (Event n)
Nothing -> NominalDiffTime -> Maybe NominalDiffTime
forall a. a -> Maybe a
Just NominalDiffTime
0
  Just Event n
is -> ((Timeframe, Sum n)
 -> Maybe NominalDiffTime -> Maybe NominalDiffTime)
-> Maybe NominalDiffTime
-> [(Timeframe, Sum n)]
-> Maybe NominalDiffTime
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Timeframe, Sum n)
-> Maybe NominalDiffTime -> Maybe NominalDiffTime
f (NominalDiffTime -> Maybe NominalDiffTime
forall a. a -> Maybe a
Just NominalDiffTime
0) (Event n -> [(Timeframe, Sum n)]
forall x y. Ord x => Layers x y -> [(Interval x, y)]
Layers.toList Event n
is)
 where
  f :: (Timeframe, Sum n) -> Maybe NominalDiffTime -> Maybe NominalDiffTime
  f :: (Timeframe, Sum n)
-> Maybe NominalDiffTime -> Maybe NominalDiffTime
f (Timeframe, Sum n)
_ Maybe NominalDiffTime
Nothing = Maybe NominalDiffTime
forall a. Maybe a
Nothing
  f (Timeframe
tf, Sum n
n) (Just NominalDiffTime
x) = case (n -> NominalDiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac n
n NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
*) (NominalDiffTime -> NominalDiffTime)
-> Maybe NominalDiffTime -> Maybe NominalDiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Timeframe -> Maybe NominalDiffTime
duration Timeframe
tf of
    Maybe NominalDiffTime
Nothing -> Maybe NominalDiffTime
forall a. Maybe a
Nothing
    Just NominalDiffTime
y -> NominalDiffTime -> Maybe NominalDiffTime
forall a. a -> Maybe a
Just (NominalDiffTime
x NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
+ NominalDiffTime
y)