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 = Layers UTCTime
type Event = Layers UTCTime (Sum Int)

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

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

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

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

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

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

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

totalDuration :: (Ord ev) => ev -> Calendar ev -> Maybe NominalDiffTime
totalDuration :: ev -> Calendar ev -> Maybe NominalDiffTime
totalDuration ev
ev (Calendar Map ev Event
c) = case Map ev Event
c Map ev Event -> ev -> Maybe Event
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? ev
ev of
  Maybe Event
Nothing -> NominalDiffTime -> Maybe NominalDiffTime
forall a. a -> Maybe a
Just NominalDiffTime
0
  Just Event
is -> ((Timeframe, Sum Int)
 -> Maybe NominalDiffTime -> Maybe NominalDiffTime)
-> Maybe NominalDiffTime
-> [(Timeframe, Sum Int)]
-> Maybe NominalDiffTime
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Timeframe, Sum Int)
-> Maybe NominalDiffTime -> Maybe NominalDiffTime
f (NominalDiffTime -> Maybe NominalDiffTime
forall a. a -> Maybe a
Just NominalDiffTime
0) (Event -> [(Timeframe, Sum Int)]
forall x y. Ord x => Layers x y -> [(Interval x, y)]
Layers.toList Event
is)
 where
  f :: (Timeframe, Sum Int) -> Maybe NominalDiffTime -> Maybe NominalDiffTime
  f :: (Timeframe, Sum Int)
-> Maybe NominalDiffTime -> Maybe NominalDiffTime
f (Timeframe, Sum Int)
_ Maybe NominalDiffTime
Nothing = Maybe NominalDiffTime
forall a. Maybe a
Nothing
  f (Timeframe
tf, Sum Int
n) (Just NominalDiffTime
x) = case (Int -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
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)