{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}

module Data.Timeline
  ( -- * Core types and functions
    Timeline (..),
    peek,
    prettyTimeline,
    changes,
    TimeRange (..),
    isTimeAfterRange,

    -- * Upper bound effectiveness time handling
    Record,
    makeRecord,
    makeRecordTH,
    recordFrom,
    recordTo,
    recordValue,
    prettyRecord,
    fromRecords,
    Overlaps (..),
    prettyOverlaps,
    OverlapGroup (..),
    unpackOverlapGroup,
  )
where

import Data.Foldable.WithIndex (FoldableWithIndex (..))
import Data.Functor.Contravariant (Contravariant, contramap)
import Data.Functor.WithIndex (FunctorWithIndex (..))
import Data.List (intercalate, sortOn)
import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map.Merge.Strict qualified as Map
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (mapMaybe, maybeToList)
import Data.Semigroup.Foldable.Class (fold1)
import Data.Set (Set)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Time
  ( UTCTime (..),
    diffTimeToPicoseconds,
    picosecondsToDiffTime,
  )
import Data.Time.Calendar.OrdinalDate (fromOrdinalDate, toOrdinalDate)
import Data.Traversable.WithIndex (TraversableWithIndex (..))
import GHC.Generics (Generic)
import GHC.Records (HasField (getField))
import Language.Haskell.TH.Syntax qualified as TH (Lift (liftTyped))
import Language.Haskell.TH.Syntax.Compat qualified as TH
import Prelude

-- | A unbounded discrete timeline for data type @a@. @'Timeline' a@ always has
-- a value for any time, but the value can only change for a finite number of
-- times.
--
-- * 'Functor', 'Foldable' and 'Traversable' instances are provided to traverse
--   through the timeline;
-- * 'FunctorWithIndex', 'Foldable' and 'TraversableWithIndex' instances are
-- provided in case you need the current time range where each value holds
-- * 'Applicative' instance can be used to merge multiple 'Timeline's together
data Timeline t a = Timeline
  { -- | the value from negative infinity time to the first time in 'values'
    forall t a. Timeline t a -> a
initialValue :: a,
    -- | changes are keyed by their "effective from" time, for easier lookup
    forall t a. Timeline t a -> Map t a
values :: Map t a
  }
  deriving stock (Int -> Timeline t a -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall t a. (Show a, Show t) => Int -> Timeline t a -> ShowS
forall t a. (Show a, Show t) => [Timeline t a] -> ShowS
forall t a. (Show a, Show t) => Timeline t a -> String
showList :: [Timeline t a] -> ShowS
$cshowList :: forall t a. (Show a, Show t) => [Timeline t a] -> ShowS
show :: Timeline t a -> String
$cshow :: forall t a. (Show a, Show t) => Timeline t a -> String
showsPrec :: Int -> Timeline t a -> ShowS
$cshowsPrec :: forall t a. (Show a, Show t) => Int -> Timeline t a -> ShowS
Show, Timeline t a -> Timeline t a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall t a. (Eq a, Eq t) => Timeline t a -> Timeline t a -> Bool
/= :: Timeline t a -> Timeline t a -> Bool
$c/= :: forall t a. (Eq a, Eq t) => Timeline t a -> Timeline t a -> Bool
== :: Timeline t a -> Timeline t a -> Bool
$c== :: forall t a. (Eq a, Eq t) => Timeline t a -> Timeline t a -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall t a x. Rep (Timeline t a) x -> Timeline t a
forall t a x. Timeline t a -> Rep (Timeline t a) x
$cto :: forall t a x. Rep (Timeline t a) x -> Timeline t a
$cfrom :: forall t a x. Timeline t a -> Rep (Timeline t a) x
Generic, forall a b. a -> Timeline t b -> Timeline t a
forall a b. (a -> b) -> Timeline t a -> Timeline t b
forall t a b. a -> Timeline t b -> Timeline t a
forall t a b. (a -> b) -> Timeline t a -> Timeline t b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Timeline t b -> Timeline t a
$c<$ :: forall t a b. a -> Timeline t b -> Timeline t a
fmap :: forall a b. (a -> b) -> Timeline t a -> Timeline t b
$cfmap :: forall t a b. (a -> b) -> Timeline t a -> Timeline t b
Functor, forall a. Timeline t a -> Bool
forall t a. Eq a => a -> Timeline t a -> Bool
forall t a. Num a => Timeline t a -> a
forall t a. Ord a => Timeline t a -> a
forall m a. Monoid m => (a -> m) -> Timeline t a -> m
forall t m. Monoid m => Timeline t m -> m
forall t a. Timeline t a -> Bool
forall t a. Timeline t a -> Int
forall t a. Timeline t a -> [a]
forall a b. (a -> b -> b) -> b -> Timeline t a -> b
forall t a. (a -> a -> a) -> Timeline t a -> a
forall t m a. Monoid m => (a -> m) -> Timeline t a -> m
forall t b a. (b -> a -> b) -> b -> Timeline t a -> b
forall t a b. (a -> b -> b) -> b -> Timeline t a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => Timeline t a -> a
$cproduct :: forall t a. Num a => Timeline t a -> a
sum :: forall a. Num a => Timeline t a -> a
$csum :: forall t a. Num a => Timeline t a -> a
minimum :: forall a. Ord a => Timeline t a -> a
$cminimum :: forall t a. Ord a => Timeline t a -> a
maximum :: forall a. Ord a => Timeline t a -> a
$cmaximum :: forall t a. Ord a => Timeline t a -> a
elem :: forall a. Eq a => a -> Timeline t a -> Bool
$celem :: forall t a. Eq a => a -> Timeline t a -> Bool
length :: forall a. Timeline t a -> Int
$clength :: forall t a. Timeline t a -> Int
null :: forall a. Timeline t a -> Bool
$cnull :: forall t a. Timeline t a -> Bool
toList :: forall a. Timeline t a -> [a]
$ctoList :: forall t a. Timeline t a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Timeline t a -> a
$cfoldl1 :: forall t a. (a -> a -> a) -> Timeline t a -> a
foldr1 :: forall a. (a -> a -> a) -> Timeline t a -> a
$cfoldr1 :: forall t a. (a -> a -> a) -> Timeline t a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> Timeline t a -> b
$cfoldl' :: forall t b a. (b -> a -> b) -> b -> Timeline t a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Timeline t a -> b
$cfoldl :: forall t b a. (b -> a -> b) -> b -> Timeline t a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Timeline t a -> b
$cfoldr' :: forall t a b. (a -> b -> b) -> b -> Timeline t a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Timeline t a -> b
$cfoldr :: forall t a b. (a -> b -> b) -> b -> Timeline t a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> Timeline t a -> m
$cfoldMap' :: forall t m a. Monoid m => (a -> m) -> Timeline t a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Timeline t a -> m
$cfoldMap :: forall t m a. Monoid m => (a -> m) -> Timeline t a -> m
fold :: forall m. Monoid m => Timeline t m -> m
$cfold :: forall t m. Monoid m => Timeline t m -> m
Foldable, forall t. Functor (Timeline t)
forall t. Foldable (Timeline t)
forall t (m :: * -> *) a.
Monad m =>
Timeline t (m a) -> m (Timeline t a)
forall t (f :: * -> *) a.
Applicative f =>
Timeline t (f a) -> f (Timeline t a)
forall t (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Timeline t a -> m (Timeline t b)
forall t (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Timeline t a -> f (Timeline t b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Timeline t a -> f (Timeline t b)
sequence :: forall (m :: * -> *) a.
Monad m =>
Timeline t (m a) -> m (Timeline t a)
$csequence :: forall t (m :: * -> *) a.
Monad m =>
Timeline t (m a) -> m (Timeline t a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Timeline t a -> m (Timeline t b)
$cmapM :: forall t (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Timeline t a -> m (Timeline t b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Timeline t (f a) -> f (Timeline t a)
$csequenceA :: forall t (f :: * -> *) a.
Applicative f =>
Timeline t (f a) -> f (Timeline t a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Timeline t a -> f (Timeline t b)
$ctraverse :: forall t (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Timeline t a -> f (Timeline t b)
Traversable)

instance Ord t => Applicative (Timeline t) where
  pure :: a -> Timeline t a
  pure :: forall a. a -> Timeline t a
pure a
a = Timeline {$sel:initialValue:Timeline :: a
initialValue = a
a, $sel:values:Timeline :: Map t a
values = forall a. Monoid a => a
mempty}

  (<*>) :: forall a b. Timeline t (a -> b) -> Timeline t a -> Timeline t b
  fs :: Timeline t (a -> b)
fs@Timeline {$sel:initialValue:Timeline :: forall t a. Timeline t a -> a
initialValue = a -> b
initialFunc, $sel:values:Timeline :: forall t a. Timeline t a -> Map t a
values = Map t (a -> b)
funcs} <*> :: forall a b. Timeline t (a -> b) -> Timeline t a -> Timeline t b
<*> xs :: Timeline t a
xs@Timeline {a
initialValue :: a
$sel:initialValue:Timeline :: forall t a. Timeline t a -> a
initialValue, Map t a
values :: Map t a
$sel:values:Timeline :: forall t a. Timeline t a -> Map t a
values} =
    Timeline
      { $sel:initialValue:Timeline :: b
initialValue = a -> b
initialFunc a
initialValue,
        $sel:values:Timeline :: Map t b
values = Map t b
mergedValues
      }
    where
      mergedValues :: Map t b
      mergedValues :: Map t b
mergedValues =
        forall k a c b.
Ord k =>
SimpleWhenMissing k a c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k a b c
-> Map k a
-> Map k b
-> Map k c
Map.merge
          (forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> y) -> WhenMissing f k x y
Map.mapMissing forall a b. (a -> b) -> a -> b
$ \t
t a -> b
f -> a -> b
f forall a b. (a -> b) -> a -> b
$ forall t a. Ord t => Timeline t a -> t -> a
peek Timeline t a
xs t
t)
          (forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> y) -> WhenMissing f k x y
Map.mapMissing forall a b. (a -> b) -> a -> b
$ \t
t a
x -> forall t a. Ord t => Timeline t a -> t -> a
peek Timeline t (a -> b)
fs t
t a
x)
          (forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> z) -> WhenMatched f k x y z
Map.zipWithMatched (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
($)))
          Map t (a -> b)
funcs
          Map t a
values

tshow :: Show a => a -> Text
tshow :: forall a. Show a => a -> Text
tshow = String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

-- | Pretty-print @'Timeline' a@. It's provided so that you can investigate the
-- value of 'Timeline' more easily. If you need to show a timeline to the end
-- user, write your own function. We don't gurantee the result to be stable
-- across different versions of this library.
prettyTimeline :: forall t a. (Ord t, Show t, Show a) => Timeline t a -> Text
prettyTimeline :: forall t a. (Ord t, Show t, Show a) => Timeline t a -> Text
prettyTimeline Timeline {a
initialValue :: a
$sel:initialValue:Timeline :: forall t a. Timeline t a -> a
initialValue, Map t a
values :: Map t a
$sel:values:Timeline :: forall t a. Timeline t a -> Map t a
values} =
  [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$
    Text
"\n----------Timeline--Start-------------"
      forall a. a -> [a] -> [a]
: (Text
"initial value:                 " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow a
initialValue)
      forall a. a -> [a] -> [a]
: forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (t, a) -> Text
showOneChange (forall k a. Map k a -> [(k, a)]
Map.toAscList Map t a
values)
      forall a. [a] -> [a] -> [a]
++ [Text
"----------Timeline--End---------------"]
  where
    showOneChange :: (t, a) -> Text
    showOneChange :: (t, a) -> Text
showOneChange (t
t, a
x) = Text
"since " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow t
t forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow a
x

-- | Extract a single value from the timeline
peek ::
  Ord t =>
  Timeline t a ->
  -- | the time to peek
  t ->
  a
peek :: forall t a. Ord t => Timeline t a -> t -> a
peek Timeline {a
Map t a
values :: Map t a
initialValue :: a
$sel:values:Timeline :: forall t a. Timeline t a -> Map t a
$sel:initialValue:Timeline :: forall t a. Timeline t a -> a
..} t
time = forall b a. b -> (a -> b) -> Maybe a -> b
maybe a
initialValue forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall k v. Ord k => k -> Map k v -> Maybe (k, v)
Map.lookupLE t
time Map t a
values

-- | A time range. Each bound is optional. 'Nothing' represents infinity.
data TimeRange t = TimeRange
  { -- | inclusive
    forall t. TimeRange t -> Maybe t
from :: Maybe t,
    -- | exclusive
    forall t. TimeRange t -> Maybe t
to :: Maybe t
  }
  deriving stock (Int -> TimeRange t -> ShowS
forall t. Show t => Int -> TimeRange t -> ShowS
forall t. Show t => [TimeRange t] -> ShowS
forall t. Show t => TimeRange t -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TimeRange t] -> ShowS
$cshowList :: forall t. Show t => [TimeRange t] -> ShowS
show :: TimeRange t -> String
$cshow :: forall t. Show t => TimeRange t -> String
showsPrec :: Int -> TimeRange t -> ShowS
$cshowsPrec :: forall t. Show t => Int -> TimeRange t -> ShowS
Show, TimeRange t -> TimeRange t -> Bool
forall t. Eq t => TimeRange t -> TimeRange t -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TimeRange t -> TimeRange t -> Bool
$c/= :: forall t. Eq t => TimeRange t -> TimeRange t -> Bool
== :: TimeRange t -> TimeRange t -> Bool
$c== :: forall t. Eq t => TimeRange t -> TimeRange t -> Bool
Eq, TimeRange t -> TimeRange t -> Bool
TimeRange t -> TimeRange t -> Ordering
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 {t}. Ord t => Eq (TimeRange t)
forall t. Ord t => TimeRange t -> TimeRange t -> Bool
forall t. Ord t => TimeRange t -> TimeRange t -> Ordering
forall t. Ord t => TimeRange t -> TimeRange t -> TimeRange t
min :: TimeRange t -> TimeRange t -> TimeRange t
$cmin :: forall t. Ord t => TimeRange t -> TimeRange t -> TimeRange t
max :: TimeRange t -> TimeRange t -> TimeRange t
$cmax :: forall t. Ord t => TimeRange t -> TimeRange t -> TimeRange t
>= :: TimeRange t -> TimeRange t -> Bool
$c>= :: forall t. Ord t => TimeRange t -> TimeRange t -> Bool
> :: TimeRange t -> TimeRange t -> Bool
$c> :: forall t. Ord t => TimeRange t -> TimeRange t -> Bool
<= :: TimeRange t -> TimeRange t -> Bool
$c<= :: forall t. Ord t => TimeRange t -> TimeRange t -> Bool
< :: TimeRange t -> TimeRange t -> Bool
$c< :: forall t. Ord t => TimeRange t -> TimeRange t -> Bool
compare :: TimeRange t -> TimeRange t -> Ordering
$ccompare :: forall t. Ord t => TimeRange t -> TimeRange t -> Ordering
Ord, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall t x. Rep (TimeRange t) x -> TimeRange t
forall t x. TimeRange t -> Rep (TimeRange t) x
$cto :: forall t x. Rep (TimeRange t) x -> TimeRange t
$cfrom :: forall t x. TimeRange t -> Rep (TimeRange t) x
Generic)

-- | If all time in 'TimeRange' is less than the given time
isTimeAfterRange :: Ord t => t -> TimeRange t -> Bool
isTimeAfterRange :: forall t. Ord t => t -> TimeRange t -> Bool
isTimeAfterRange t
t TimeRange {Maybe t
to :: Maybe t
$sel:to:TimeRange :: forall t. TimeRange t -> Maybe t
to} = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (t
t forall a. Ord a => a -> a -> Bool
>=) Maybe t
to

instance Ord t => FunctorWithIndex (TimeRange t) (Timeline t) where
  imap :: (TimeRange t -> a -> b) -> Timeline t a -> Timeline t b
  imap :: forall a b. (TimeRange t -> a -> b) -> Timeline t a -> Timeline t b
imap TimeRange t -> a -> b
f Timeline {a
Map t a
values :: Map t a
initialValue :: a
$sel:values:Timeline :: forall t a. Timeline t a -> Map t a
$sel:initialValue:Timeline :: forall t a. Timeline t a -> a
..} =
    Timeline
      { $sel:initialValue:Timeline :: b
initialValue = TimeRange t -> a -> b
f TimeRange t
initialRange a
initialValue,
        $sel:values:Timeline :: Map t b
values = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey Map t a
values forall a b. (a -> b) -> a -> b
$ \t
from a
value ->
          let timeRange :: TimeRange t
timeRange = forall t. Maybe t -> Maybe t -> TimeRange t
TimeRange (forall a. a -> Maybe a
Just t
from) (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v. Ord k => k -> Map k v -> Maybe (k, v)
Map.lookupGT t
from Map t a
values)
           in TimeRange t -> a -> b
f TimeRange t
timeRange a
value
      }
    where
      initialRange :: TimeRange t
initialRange = forall t. Maybe t -> Maybe t -> TimeRange t
TimeRange forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> Maybe (k, a)
Map.lookupMin Map t a
values

instance Ord t => FoldableWithIndex (TimeRange t) (Timeline t)

instance Ord t => TraversableWithIndex (TimeRange t) (Timeline t) where
  itraverse :: (Applicative f) => (TimeRange t -> a -> f b) -> Timeline t a -> f (Timeline t b)
  itraverse :: forall (f :: * -> *) a b.
Applicative f =>
(TimeRange t -> a -> f b) -> Timeline t a -> f (Timeline t b)
itraverse TimeRange t -> a -> f b
f = forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i (f :: * -> *) a b.
FunctorWithIndex i f =>
(i -> a -> b) -> f a -> f b
imap TimeRange t -> a -> f b
f

-- | Return the set of time when the value changes
changes :: Timeline t a -> Set t
changes :: forall t a. Timeline t a -> Set t
changes Timeline {Map t a
values :: Map t a
$sel:values:Timeline :: forall t a. Timeline t a -> Map t a
values} = forall k a. Map k a -> Set k
Map.keysSet Map t a
values

-- | A value with @effectiveFrom@ and @effectiveTo@ attached. This is often the
-- type we get from inputs. A list of @'Record' a@ can be converted to
-- @'Timeline' ('Maybe' a)@. See 'fromRecords'.
data Record t a = Record
  { -- | inclusive
    forall t a. Record t a -> t
from :: t,
    -- | exclusive. When 'Nothing', the record never expires, until there is
    -- another record with a newer 'effectiveFrom' time.
    forall t a. Record t a -> Maybe t
to :: Maybe t,
    forall t a. Record t a -> a
value :: a
  }
  deriving stock (Int -> Record t a -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall t a. (Show t, Show a) => Int -> Record t a -> ShowS
forall t a. (Show t, Show a) => [Record t a] -> ShowS
forall t a. (Show t, Show a) => Record t a -> String
showList :: [Record t a] -> ShowS
$cshowList :: forall t a. (Show t, Show a) => [Record t a] -> ShowS
show :: Record t a -> String
$cshow :: forall t a. (Show t, Show a) => Record t a -> String
showsPrec :: Int -> Record t a -> ShowS
$cshowsPrec :: forall t a. (Show t, Show a) => Int -> Record t a -> ShowS
Show, Record t a -> Record t a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall t a. (Eq t, Eq a) => Record t a -> Record t a -> Bool
/= :: Record t a -> Record t a -> Bool
$c/= :: forall t a. (Eq t, Eq a) => Record t a -> Record t a -> Bool
== :: Record t a -> Record t a -> Bool
$c== :: forall t a. (Eq t, Eq a) => Record t a -> Record t a -> Bool
Eq, forall a b. a -> Record t b -> Record t a
forall a b. (a -> b) -> Record t a -> Record t b
forall t a b. a -> Record t b -> Record t a
forall t a b. (a -> b) -> Record t a -> Record t b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Record t b -> Record t a
$c<$ :: forall t a b. a -> Record t b -> Record t a
fmap :: forall a b. (a -> b) -> Record t a -> Record t b
$cfmap :: forall t a b. (a -> b) -> Record t a -> Record t b
Functor, forall a. Record t a -> Bool
forall t a. Eq a => a -> Record t a -> Bool
forall t a. Num a => Record t a -> a
forall t a. Ord a => Record t a -> a
forall m a. Monoid m => (a -> m) -> Record t a -> m
forall t m. Monoid m => Record t m -> m
forall t a. Record t a -> Bool
forall t a. Record t a -> Int
forall t a. Record t a -> [a]
forall a b. (a -> b -> b) -> b -> Record t a -> b
forall t a. (a -> a -> a) -> Record t a -> a
forall t m a. Monoid m => (a -> m) -> Record t a -> m
forall t b a. (b -> a -> b) -> b -> Record t a -> b
forall t a b. (a -> b -> b) -> b -> Record t a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => Record t a -> a
$cproduct :: forall t a. Num a => Record t a -> a
sum :: forall a. Num a => Record t a -> a
$csum :: forall t a. Num a => Record t a -> a
minimum :: forall a. Ord a => Record t a -> a
$cminimum :: forall t a. Ord a => Record t a -> a
maximum :: forall a. Ord a => Record t a -> a
$cmaximum :: forall t a. Ord a => Record t a -> a
elem :: forall a. Eq a => a -> Record t a -> Bool
$celem :: forall t a. Eq a => a -> Record t a -> Bool
length :: forall a. Record t a -> Int
$clength :: forall t a. Record t a -> Int
null :: forall a. Record t a -> Bool
$cnull :: forall t a. Record t a -> Bool
toList :: forall a. Record t a -> [a]
$ctoList :: forall t a. Record t a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Record t a -> a
$cfoldl1 :: forall t a. (a -> a -> a) -> Record t a -> a
foldr1 :: forall a. (a -> a -> a) -> Record t a -> a
$cfoldr1 :: forall t a. (a -> a -> a) -> Record t a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> Record t a -> b
$cfoldl' :: forall t b a. (b -> a -> b) -> b -> Record t a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Record t a -> b
$cfoldl :: forall t b a. (b -> a -> b) -> b -> Record t a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Record t a -> b
$cfoldr' :: forall t a b. (a -> b -> b) -> b -> Record t a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Record t a -> b
$cfoldr :: forall t a b. (a -> b -> b) -> b -> Record t a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> Record t a -> m
$cfoldMap' :: forall t m a. Monoid m => (a -> m) -> Record t a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Record t a -> m
$cfoldMap :: forall t m a. Monoid m => (a -> m) -> Record t a -> m
fold :: forall m. Monoid m => Record t m -> m
$cfold :: forall t m. Monoid m => Record t m -> m
Foldable, forall t. Functor (Record t)
forall t. Foldable (Record t)
forall t (m :: * -> *) a.
Monad m =>
Record t (m a) -> m (Record t a)
forall t (f :: * -> *) a.
Applicative f =>
Record t (f a) -> f (Record t a)
forall t (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Record t a -> m (Record t b)
forall t (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Record t a -> f (Record t b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Record t a -> f (Record t b)
sequence :: forall (m :: * -> *) a. Monad m => Record t (m a) -> m (Record t a)
$csequence :: forall t (m :: * -> *) a.
Monad m =>
Record t (m a) -> m (Record t a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Record t a -> m (Record t b)
$cmapM :: forall t (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Record t a -> m (Record t b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Record t (f a) -> f (Record t a)
$csequenceA :: forall t (f :: * -> *) a.
Applicative f =>
Record t (f a) -> f (Record t a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Record t a -> f (Record t b)
$ctraverse :: forall t (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Record t a -> f (Record t b)
Traversable, forall t a (m :: * -> *).
(Lift t, Lift a, Quote m) =>
Record t a -> m Exp
forall t a (m :: * -> *).
(Lift t, Lift a, Quote m) =>
Record t a -> Code m (Record t a)
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Record t a -> m Exp
forall (m :: * -> *). Quote m => Record t a -> Code m (Record t a)
liftTyped :: forall (m :: * -> *). Quote m => Record t a -> Code m (Record t a)
$cliftTyped :: forall t a (m :: * -> *).
(Lift t, Lift a, Quote m) =>
Record t a -> Code m (Record t a)
lift :: forall (m :: * -> *). Quote m => Record t a -> m Exp
$clift :: forall t a (m :: * -> *).
(Lift t, Lift a, Quote m) =>
Record t a -> m Exp
TH.Lift)

-- | Get the "effective from" time
recordFrom :: Record t a -> t
recordFrom :: forall t a. Record t a -> t
recordFrom Record {t
from :: t
$sel:from:Record :: forall t a. Record t a -> t
from} = t
from

-- | Get the "effective to" time
recordTo :: Record t a -> Maybe t
recordTo :: forall t a. Record t a -> Maybe t
recordTo Record {Maybe t
to :: Maybe t
$sel:to:Record :: forall t a. Record t a -> Maybe t
to} = Maybe t
to

-- | Get the value wrapped in a @'Record' a@
recordValue :: Record t a -> a
recordValue :: forall t a. Record t a -> a
recordValue = forall t a. Record t a -> a
value

-- | A smart constructor for @'Record' a@.
-- Returns 'Nothing' if @effectiveTo@ is not greater than @effectiveFrom@
makeRecord ::
  Ord t =>
  -- | effective from
  t ->
  -- | optional effective to
  Maybe t ->
  -- | value
  a ->
  Maybe (Record t a)
makeRecord :: forall t a. Ord t => t -> Maybe t -> a -> Maybe (Record t a)
makeRecord t
from Maybe t
to a
value =
  if forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (t
from forall a. Ord a => a -> a -> Bool
>=) Maybe t
to
    then forall a. Maybe a
Nothing
    else forall a. a -> Maybe a
Just Record {t
a
Maybe t
value :: a
to :: Maybe t
from :: t
$sel:value:Record :: a
$sel:to:Record :: Maybe t
$sel:from:Record :: t
..}

-- | Template Haskell counterpart of 'makeRecord'.
makeRecordTH ::
  (Ord t, TH.Lift (Record t a)) =>
  t ->
  Maybe t ->
  a ->
  TH.SpliceQ (Record t a)
makeRecordTH :: forall t a.
(Ord t, Lift (Record t a)) =>
t -> Maybe t -> a -> SpliceQ (Record t a)
makeRecordTH t
effectiveFrom Maybe t
effectiveTo a
value =
  forall (m :: * -> *) a b.
Monad m =>
m a -> (a -> Splice m b) -> Splice m b
TH.bindSplice
    ( forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"effective to is no greater than effective from") forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        forall t a. Ord t => t -> Maybe t -> a -> Maybe (Record t a)
makeRecord t
effectiveFrom Maybe t
effectiveTo a
value
    )
    forall t (m :: * -> *). (Lift t, Quote m) => t -> Code m t
TH.liftTyped

-- | Special support for 'UTCTime'. This will be removed when 'TH.Lift'
-- instances are provided by the @time@ package directly.
instance {-# OVERLAPPING #-} (TH.Lift a) => TH.Lift (Record UTCTime a) where
  liftTyped :: forall (m :: * -> *).
Quote m =>
Record UTCTime a -> Code m (Record UTCTime a)
liftTyped Record {a
Maybe UTCTime
UTCTime
value :: a
to :: Maybe UTCTime
from :: UTCTime
$sel:value:Record :: forall t a. Record t a -> a
$sel:to:Record :: forall t a. Record t a -> Maybe t
$sel:from:Record :: forall t a. Record t a -> t
..} =
    [||
    Record
      (unLiftUTCTime $$(TH.liftTyped $ LiftUTCTime from))
      (fmap unLiftUTCTime $$(TH.liftTyped $ LiftUTCTime <$> to))
      $$(TH.liftTyped value)
    ||]

newtype LiftUTCTime = LiftUTCTime UTCTime
  deriving stock (forall x. Rep LiftUTCTime x -> LiftUTCTime
forall x. LiftUTCTime -> Rep LiftUTCTime x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep LiftUTCTime x -> LiftUTCTime
$cfrom :: forall x. LiftUTCTime -> Rep LiftUTCTime x
Generic)

unLiftUTCTime :: LiftUTCTime -> UTCTime
unLiftUTCTime :: LiftUTCTime -> UTCTime
unLiftUTCTime (LiftUTCTime UTCTime
t) = UTCTime
t

instance TH.Lift LiftUTCTime where
  liftTyped :: forall (m :: * -> *). Quote m => LiftUTCTime -> Code m LiftUTCTime
liftTyped (LiftUTCTime (UTCTime (Day -> (Year, Int)
toOrdinalDate -> (Year
year, Int
day)) DiffTime
diffTime)) =
    [||
    LiftUTCTime $
      UTCTime
        (fromOrdinalDate $$(TH.liftTyped year) $$(TH.liftTyped day))
        (picosecondsToDiffTime $$(TH.liftTyped (diffTimeToPicoseconds diffTime)))
    ||]

-- | Pretty-print @'Record' a@, like 'prettyTimeline'.
prettyRecord :: (Show t, Show a) => Record t a -> Text
prettyRecord :: forall t a. (Show t, Show a) => Record t a -> Text
prettyRecord Record {t
a
Maybe t
value :: a
to :: Maybe t
from :: t
$sel:value:Record :: forall t a. Record t a -> a
$sel:to:Record :: forall t a. Record t a -> Maybe t
$sel:from:Record :: forall t a. Record t a -> t
..} = forall a. Show a => a -> Text
tshow t
from forall a. Semigroup a => a -> a -> a
<> Text
" ~ " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow Maybe t
to forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow a
value

-- | An @'Overlaps' a@ consists of several groups. Within each group, all
-- records are connected. Definition of connectivity: two records are
-- "connected" if and only if they overlap.
newtype Overlaps t a = Overlaps {forall t a. Overlaps t a -> NonEmpty (OverlapGroup t a)
groups :: NonEmpty (OverlapGroup t a)}
  deriving newtype (NonEmpty (Overlaps t a) -> Overlaps t a
Overlaps t a -> Overlaps t a -> Overlaps t a
forall b. Integral b => b -> Overlaps t a -> Overlaps t a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall t a. NonEmpty (Overlaps t a) -> Overlaps t a
forall t a. Overlaps t a -> Overlaps t a -> Overlaps t a
forall t a b. Integral b => b -> Overlaps t a -> Overlaps t a
stimes :: forall b. Integral b => b -> Overlaps t a -> Overlaps t a
$cstimes :: forall t a b. Integral b => b -> Overlaps t a -> Overlaps t a
sconcat :: NonEmpty (Overlaps t a) -> Overlaps t a
$csconcat :: forall t a. NonEmpty (Overlaps t a) -> Overlaps t a
<> :: Overlaps t a -> Overlaps t a -> Overlaps t a
$c<> :: forall t a. Overlaps t a -> Overlaps t a -> Overlaps t a
Semigroup)
  deriving stock (Int -> Overlaps t a -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall t a. (Show t, Show a) => Int -> Overlaps t a -> ShowS
forall t a. (Show t, Show a) => [Overlaps t a] -> ShowS
forall t a. (Show t, Show a) => Overlaps t a -> String
showList :: [Overlaps t a] -> ShowS
$cshowList :: forall t a. (Show t, Show a) => [Overlaps t a] -> ShowS
show :: Overlaps t a -> String
$cshow :: forall t a. (Show t, Show a) => Overlaps t a -> String
showsPrec :: Int -> Overlaps t a -> ShowS
$cshowsPrec :: forall t a. (Show t, Show a) => Int -> Overlaps t a -> ShowS
Show, Overlaps t a -> Overlaps t a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall t a. (Eq t, Eq a) => Overlaps t a -> Overlaps t a -> Bool
/= :: Overlaps t a -> Overlaps t a -> Bool
$c/= :: forall t a. (Eq t, Eq a) => Overlaps t a -> Overlaps t a -> Bool
== :: Overlaps t a -> Overlaps t a -> Bool
$c== :: forall t a. (Eq t, Eq a) => Overlaps t a -> Overlaps t a -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall t a x. Rep (Overlaps t a) x -> Overlaps t a
forall t a x. Overlaps t a -> Rep (Overlaps t a) x
$cto :: forall t a x. Rep (Overlaps t a) x -> Overlaps t a
$cfrom :: forall t a x. Overlaps t a -> Rep (Overlaps t a) x
Generic)

-- | Pretty-print @'Overlaps' a@, like 'prettyTimeline'.
prettyOverlaps :: (Show t, Show a) => Overlaps t a -> Text
prettyOverlaps :: forall t a. (Show t, Show a) => Overlaps t a -> Text
prettyOverlaps Overlaps {NonEmpty (OverlapGroup t a)
groups :: NonEmpty (OverlapGroup t a)
$sel:groups:Overlaps :: forall t a. Overlaps t a -> NonEmpty (OverlapGroup t a)
groups} =
  Text
"Here are "
    forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow (forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty (OverlapGroup t a)
groups)
    forall a. Semigroup a => a -> a -> a
<> Text
" group(s) of overlapping records\n"
    forall a. Semigroup a => a -> a -> a
<> Text
sep
    forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
sep (forall t a. (Show t, Show a) => OverlapGroup t a -> Text
prettyOverlapGroup forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty (OverlapGroup t a)
groups)
    forall a. Semigroup a => a -> a -> a
<> Text
sep
  where
    sep :: Text
sep = Text
"--------------------\n"

-- | A group of overlapping records. There must be at least two records within a group.
data OverlapGroup t a = OverlapGroup (Record t a) (Record t a) [Record t a]
  deriving stock (Int -> OverlapGroup t a -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall t a. (Show t, Show a) => Int -> OverlapGroup t a -> ShowS
forall t a. (Show t, Show a) => [OverlapGroup t a] -> ShowS
forall t a. (Show t, Show a) => OverlapGroup t a -> String
showList :: [OverlapGroup t a] -> ShowS
$cshowList :: forall t a. (Show t, Show a) => [OverlapGroup t a] -> ShowS
show :: OverlapGroup t a -> String
$cshow :: forall t a. (Show t, Show a) => OverlapGroup t a -> String
showsPrec :: Int -> OverlapGroup t a -> ShowS
$cshowsPrec :: forall t a. (Show t, Show a) => Int -> OverlapGroup t a -> ShowS
Show, OverlapGroup t a -> OverlapGroup t a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall t a.
(Eq t, Eq a) =>
OverlapGroup t a -> OverlapGroup t a -> Bool
/= :: OverlapGroup t a -> OverlapGroup t a -> Bool
$c/= :: forall t a.
(Eq t, Eq a) =>
OverlapGroup t a -> OverlapGroup t a -> Bool
== :: OverlapGroup t a -> OverlapGroup t a -> Bool
$c== :: forall t a.
(Eq t, Eq a) =>
OverlapGroup t a -> OverlapGroup t a -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall t a x. Rep (OverlapGroup t a) x -> OverlapGroup t a
forall t a x. OverlapGroup t a -> Rep (OverlapGroup t a) x
$cto :: forall t a x. Rep (OverlapGroup t a) x -> OverlapGroup t a
$cfrom :: forall t a x. OverlapGroup t a -> Rep (OverlapGroup t a) x
Generic)

prettyOverlapGroup :: (Show t, Show a) => OverlapGroup t a -> Text
prettyOverlapGroup :: forall t a. (Show t, Show a) => OverlapGroup t a -> Text
prettyOverlapGroup = [Text] -> Text
T.unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall t a. (Show t, Show a) => Record t a -> Text
prettyRecord forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. OverlapGroup t a -> [Record t a]
unpackOverlapGroup

-- | Unpack @'OverlapGroup' a@ as a list of records.
unpackOverlapGroup :: OverlapGroup t a -> [Record t a]
unpackOverlapGroup :: forall t a. OverlapGroup t a -> [Record t a]
unpackOverlapGroup (OverlapGroup Record t a
r1 Record t a
r2 [Record t a]
records) = Record t a
r1 forall a. a -> [a] -> [a]
: Record t a
r2 forall a. a -> [a] -> [a]
: [Record t a]
records

-- | Build a 'Timeline' from a list of 'Record's.
--
-- For any time, there could be zero, one, or more values, according to the
-- input. No other condition is possible. We have taken account the "zero" case
-- by wrapping the result in 'Maybe', so the only possible error is 'Overlaps'.
-- The 'Traversable' instance of @'Timeline' a@ can be used to convert
-- @'Timeline' ('Maybe' a)@ to @'Maybe' ('Timeline' a)@
fromRecords :: forall t a. Ord t => [Record t a] -> Either (Overlaps t a) (Timeline t (Maybe a))
fromRecords :: forall t a.
Ord t =>
[Record t a] -> Either (Overlaps t a) (Timeline t (Maybe a))
fromRecords [Record t a]
records =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. b -> Either a b
Right Timeline t (Maybe a)
timeline) forall a b. a -> Either a b
Left Maybe (Overlaps t a)
overlaps
  where
    sortedRecords :: [Record t a]
sortedRecords = forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall t a. Record t a -> t
recordFrom [Record t a]
records

    -- overlap detection
    overlaps :: Maybe (Overlaps t a)
overlaps =
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) m. (Foldable1 t, Semigroup m) => t m -> m
fold1
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe (NonEmpty a)
nonEmpty
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe NonEmpty (Record t a) -> Maybe (Overlaps t a)
checkForOverlap
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Record t a -> [NonEmpty (Record t a)] -> [NonEmpty (Record t a)]
mergeOverlappingNeighbours []
        forall a b. (a -> b) -> a -> b
$ [Record t a]
sortedRecords

    mergeOverlappingNeighbours ::
      Record t a ->
      [NonEmpty (Record t a)] ->
      [NonEmpty (Record t a)]
    mergeOverlappingNeighbours :: Record t a -> [NonEmpty (Record t a)] -> [NonEmpty (Record t a)]
mergeOverlappingNeighbours Record t a
current ((Record t a
next :| [Record t a]
group) : [NonEmpty (Record t a)]
groups)
      -- Be aware that this is called in 'foldr', so it traverse the list from
      -- right to left. If the current record overlaps with the top (left-most)
      -- record in the next group, we add it to the group. Otherwise, create a
      -- new group for it.
      | Bool
isOverlapping = (Record t a
current forall a. a -> NonEmpty a -> NonEmpty a
NonEmpty.<| Record t a
next forall a. a -> [a] -> NonEmpty a
:| [Record t a]
group) forall a. a -> [a] -> [a]
: [NonEmpty (Record t a)]
groups
      | Bool
otherwise = (Record t a
current forall a. a -> [a] -> NonEmpty a
:| []) forall a. a -> [a] -> [a]
: (Record t a
next forall a. a -> [a] -> NonEmpty a
:| [Record t a]
group) forall a. a -> [a] -> [a]
: [NonEmpty (Record t a)]
groups
      where
        isOverlapping :: Bool
isOverlapping = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall t a. Record t a -> t
recordFrom Record t a
next forall a. Ord a => a -> a -> Bool
<) (forall t a. Record t a -> Maybe t
recordTo Record t a
current)
    mergeOverlappingNeighbours Record t a
current [] = [Record t a
current forall a. a -> [a] -> NonEmpty a
:| []]

    checkForOverlap :: NonEmpty (Record t a) -> Maybe (Overlaps t a)
    checkForOverlap :: NonEmpty (Record t a) -> Maybe (Overlaps t a)
checkForOverlap (Record t a
_ :| []) = forall a. Maybe a
Nothing
    checkForOverlap (Record t a
x1 :| Record t a
x2 : [Record t a]
xs) = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. NonEmpty (OverlapGroup t a) -> Overlaps t a
Overlaps forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> NonEmpty a
:| []) forall a b. (a -> b) -> a -> b
$ forall t a.
Record t a -> Record t a -> [Record t a] -> OverlapGroup t a
OverlapGroup Record t a
x1 Record t a
x2 [Record t a]
xs

    -- build the timeline assuming all elements of `sortedRecords` cover
    -- distinct (non-overlapping) time-periods
    timeline :: Timeline t (Maybe a)
    timeline :: Timeline t (Maybe a)
timeline =
      case forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Record t a]
sortedRecords of
        Maybe (NonEmpty (Record t a))
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        Just NonEmpty (Record t a)
records' ->
          Timeline
            { $sel:initialValue:Timeline :: Maybe a
initialValue = forall a. Maybe a
Nothing,
              $sel:values:Timeline :: Map t (Maybe a)
values =
                forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
                  forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
                    Record t a -> Maybe (Record t a) -> [(t, Maybe a)]
connectAdjacentRecords
                    (forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty (Record t a)
records')
                    ((forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. NonEmpty a -> [a]
NonEmpty.tail NonEmpty (Record t a)
records') forall a. Semigroup a => a -> a -> a
<> [forall a. Maybe a
Nothing])
            }
    connectAdjacentRecords :: Record t a -> Maybe (Record t a) -> [(t, Maybe a)]
    connectAdjacentRecords :: Record t a -> Maybe (Record t a) -> [(t, Maybe a)]
connectAdjacentRecords Record t a
current Maybe (Record t a)
next =
      (forall t a. Record t a -> t
recordFrom Record t a
current, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall t a. Record t a -> a
value Record t a
current)
        forall a. a -> [a] -> [a]
: forall a. Maybe a -> [a]
maybeToList Maybe (t, Maybe a)
gap
      where
        gap :: Maybe (t, Maybe a)
gap = do
          t
effectiveTo' <- forall t a. Record t a -> Maybe t
recordTo Record t a
current
          if forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (\Record t a
next' -> t
effectiveTo' forall a. Ord a => a -> a -> Bool
< forall t a. Record t a -> t
recordFrom Record t a
next') Maybe (Record t a)
next
            then forall (f :: * -> *) a. Applicative f => a -> f a
pure (t
effectiveTo', forall a. Maybe a
Nothing)
            else forall a. Maybe a
Nothing