timeline (empty) → 0.1.0.0
raw patch · 13 files changed
+836/−0 lines, 13 filesdep +basedep +bytestringdep +containers
Dependencies added: base, bytestring, containers, hashable, hedgehog, indexed-traversable, semigroupoids, tasty, tasty-golden, tasty-hedgehog, tasty-hunit, template-haskell, text, th-compat, time, timeline, transformers
Files
- CHANGELOG.md +4/−0
- LICENSE +29/−0
- README.md +41/−0
- src/Data/Timeline.hs +358/−0
- src/Data/Timeline/Hedgehog.hs +40/−0
- test/Data/TimelineTest.hs +257/−0
- test/Main.hs +1/−0
- test/golden/all_non-overlapping_situations_together.txt +10/−0
- test/golden/one_change,_with_effective_to.txt +6/−0
- test/golden/one_change.txt +5/−0
- test/golden/overlaps.txt +6/−0
- test/golden/two_groups_of_overlap.txt +8/−0
- timeline.cabal +71/−0
+ CHANGELOG.md view
@@ -0,0 +1,4 @@+# Changelog++## 0.1.0.0+- Open source the timeline library we use internally at Bellroy
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (C) 2023 Bellroy Pty Ltd++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the+ distribution.++3. Neither the name of the copyright holder nor the names of its+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,41 @@+# timeline++## Motivation++The world is always changing, and often we want to manage the changes of data+using computers. Below are some concrete examples:++- Employee data such as compensation, city, tax rule, time-off, etc.+- Prices of products. A product could have different prices on Amazon and EBay,+ and in different currencies.++Timeline data is often implemented by attaching extra fields to your business+object, denoting the start and end time of each interval. However, only+representing and storing the data is not sufficient, we need to run operations+on timeline data, like extracting a single data point at some specific time,+merging multiple timelines together, etc.++If you have a similar use case and don't want to reinvent the wheel, this+library is for you.++## Module Organization++- `Data.Timeline` essential types and functions+- `Data.Timeline.Hedgehog` hedgehog generators for timeline types++## Getting Started++The core type is `Timeline a`, refer to+[Haddock](https://hackage.haskell.org/package/timeline-0.0.1.0/docs/Data-Timeline.html)+for its usage.++## Contribution+Bellroy actively maintains this project. Feel free to submit issues and+pull requests!++The code is formatted with [`ormolu`](https://hackage.haskell.org/package/ormolu)++If you use Nix:+- `nix develop` enter a shell with all necessary tools+- `nix build` build and run tests on all GHC versions we support+- Use `nix flake show` to view a full list of outputs
+ src/Data/Timeline.hs view
@@ -0,0 +1,358 @@+{-# 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'+ initialValue :: a,+ -- | changes are keyed by their "effective from" time, for easier lookup+ values :: Map t a+ }+ deriving stock (Show, Eq, Generic, Functor, Foldable, Traversable)++instance Ord t => Applicative (Timeline t) where+ pure :: a -> Timeline t a+ pure a = Timeline {initialValue = a, values = mempty}++ (<*>) :: forall a b. Timeline t (a -> b) -> Timeline t a -> Timeline t b+ fs@Timeline {initialValue = initialFunc, values = funcs} <*> xs@Timeline {initialValue, values} =+ Timeline+ { initialValue = initialFunc initialValue,+ values = mergedValues+ }+ where+ mergedValues :: Map t b+ mergedValues =+ Map.merge+ (Map.mapMissing $ \t f -> f $ peek xs t)+ (Map.mapMissing $ \t x -> peek fs t x)+ (Map.zipWithMatched (const ($)))+ funcs+ values++tshow :: Show a => a -> Text+tshow = T.pack . 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 Timeline {initialValue, values} =+ T.unlines $+ "\n----------Timeline--Start-------------"+ : ("initial value: " <> tshow initialValue)+ : fmap showOneChange (Map.toAscList values)+ ++ ["----------Timeline--End---------------"]+ where+ showOneChange :: (t, a) -> Text+ showOneChange (t, x) = "since " <> tshow t <> ": " <> tshow x++-- | Extract a single value from the timeline+peek ::+ Ord t =>+ Timeline t a ->+ -- | the time to peek+ t ->+ a+peek Timeline {..} time = maybe initialValue snd $ Map.lookupLE time values++-- | A time range. Each bound is optional. 'Nothing' represents infinity.+data TimeRange t = TimeRange+ { -- | inclusive+ from :: Maybe t,+ -- | exclusive+ to :: Maybe t+ }+ deriving stock (Show, Eq, Ord, Generic)++-- | If all time in 'TimeRange' is less than the given time+isTimeAfterRange :: Ord t => t -> TimeRange t -> Bool+isTimeAfterRange t TimeRange {to} = maybe False (t >=) to++instance Ord t => FunctorWithIndex (TimeRange t) (Timeline t) where+ imap :: (TimeRange t -> a -> b) -> Timeline t a -> Timeline t b+ imap f Timeline {..} =+ Timeline+ { initialValue = f initialRange initialValue,+ values = flip Map.mapWithKey values $ \from value ->+ let timeRange = TimeRange (Just from) (fst <$> Map.lookupGT from values)+ in f timeRange value+ }+ where+ initialRange = TimeRange Nothing $ fst <$> Map.lookupMin 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 f = sequenceA . imap f++-- | Return the set of time when the value changes+changes :: Timeline t a -> Set t+changes Timeline {values} = Map.keysSet 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+ from :: t,+ -- | exclusive. When 'Nothing', the record never expires, until there is+ -- another record with a newer 'effectiveFrom' time.+ to :: Maybe t,+ value :: a+ }+ deriving stock (Show, Eq, Functor, Foldable, Traversable, TH.Lift)++-- | Get the "effective from" time+recordFrom :: Record t a -> t+recordFrom Record {from} = from++-- | Get the "effective to" time+recordTo :: Record t a -> Maybe t+recordTo Record {to} = to++-- | Get the value wrapped in a @'Record' a@+recordValue :: Record t a -> a+recordValue = 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 from to value =+ if maybe False (from >=) to+ then Nothing+ else Just Record {..}++-- | Template Haskell counterpart of 'makeRecord'.+makeRecordTH ::+ (Ord t, TH.Lift (Record t a)) =>+ t ->+ Maybe t ->+ a ->+ TH.SpliceQ (Record t a)+makeRecordTH effectiveFrom effectiveTo value =+ TH.bindSplice+ ( maybe (fail "effective to is no greater than effective from") pure $+ makeRecord effectiveFrom effectiveTo value+ )+ 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 Record {..} =+ [||+ Record+ (unLiftUTCTime $$(TH.liftTyped $ LiftUTCTime from))+ (fmap unLiftUTCTime $$(TH.liftTyped $ LiftUTCTime <$> to))+ $$(TH.liftTyped value)+ ||]++newtype LiftUTCTime = LiftUTCTime UTCTime+ deriving stock (Generic)++unLiftUTCTime :: LiftUTCTime -> UTCTime+unLiftUTCTime (LiftUTCTime t) = t++instance TH.Lift LiftUTCTime where+ liftTyped (LiftUTCTime (UTCTime (toOrdinalDate -> (year, day)) 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 Record {..} = tshow from <> " ~ " <> tshow to <> ": " <> tshow 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 {groups :: NonEmpty (OverlapGroup t a)}+ deriving newtype (Semigroup)+ deriving stock (Show, Eq, Generic)++-- | Pretty-print @'Overlaps' a@, like 'prettyTimeline'.+prettyOverlaps :: (Show t, Show a) => Overlaps t a -> Text+prettyOverlaps Overlaps {groups} =+ "Here are "+ <> tshow (length groups)+ <> " group(s) of overlapping records\n"+ <> sep+ <> T.intercalate sep (prettyOverlapGroup <$> NonEmpty.toList groups)+ <> sep+ where+ sep = "--------------------\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 (Show, Eq, Generic)++prettyOverlapGroup :: (Show t, Show a) => OverlapGroup t a -> Text+prettyOverlapGroup = T.unlines . fmap prettyRecord . unpackOverlapGroup++-- | Unpack @'OverlapGroup' a@ as a list of records.+unpackOverlapGroup :: OverlapGroup t a -> [Record t a]+unpackOverlapGroup (OverlapGroup r1 r2 records) = r1 : r2 : 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 records =+ maybe (Right timeline) Left overlaps+ where+ sortedRecords = sortOn recordFrom records++ -- overlap detection+ overlaps =+ fmap fold1+ . nonEmpty+ . mapMaybe checkForOverlap+ . foldr mergeOverlappingNeighbours []+ $ sortedRecords++ mergeOverlappingNeighbours ::+ Record t a ->+ [NonEmpty (Record t a)] ->+ [NonEmpty (Record t a)]+ mergeOverlappingNeighbours current ((next :| group) : 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.+ | isOverlapping = (current NonEmpty.<| next :| group) : groups+ | otherwise = (current :| []) : (next :| group) : groups+ where+ isOverlapping = maybe False (recordFrom next <) (recordTo current)+ mergeOverlappingNeighbours current [] = [current :| []]++ checkForOverlap :: NonEmpty (Record t a) -> Maybe (Overlaps t a)+ checkForOverlap (_ :| []) = Nothing+ checkForOverlap (x1 :| x2 : xs) = Just . Overlaps . (:| []) $ OverlapGroup x1 x2 xs++ -- build the timeline assuming all elements of `sortedRecords` cover+ -- distinct (non-overlapping) time-periods+ timeline :: Timeline t (Maybe a)+ timeline =+ case nonEmpty sortedRecords of+ Nothing -> pure Nothing+ Just records' ->+ Timeline+ { initialValue = Nothing,+ values =+ Map.fromList . concat $+ zipWith+ connectAdjacentRecords+ (NonEmpty.toList records')+ ((Just <$> NonEmpty.tail records') <> [Nothing])+ }+ connectAdjacentRecords :: Record t a -> Maybe (Record t a) -> [(t, Maybe a)]+ connectAdjacentRecords current next =+ (recordFrom current, Just $ value current)+ : maybeToList gap+ where+ gap = do+ effectiveTo' <- recordTo current+ if maybe True (\next' -> effectiveTo' < recordFrom next') next+ then pure (effectiveTo', Nothing)+ else Nothing
+ src/Data/Timeline/Hedgehog.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE NamedFieldPuns #-}++-- | Hedgehog generators for the timeline library.+module Data.Timeline.Hedgehog+ ( -- * Timeline Generators+ gen,+ genRecord,+ )+where++import Data.Timeline+import Hedgehog (MonadGen)+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range++-- | Generator for @'Timeline' a@+gen ::+ (MonadGen m, Ord t) =>+ m t ->+ -- | Generator for values+ m a ->+ m (Timeline t a)+gen genTime genValue = do+ initialValue <- genValue+ values <- Gen.map (Range.linear 0 20) $ (,) <$> genTime <*> genValue+ pure Timeline {initialValue, values}++-- | Generator for @'Record' a@+genRecord ::+ (MonadGen m, Ord t) =>+ m t ->+ -- | Generator for the value+ m a ->+ m (Record t a)+genRecord genTime genValue =+ Gen.justT $ do+ t1 <- genTime+ t2 <- Gen.maybe $ Gen.filterT (/= t1) genTime+ makeRecord t1 t2 <$> genValue
+ test/Data/TimelineTest.hs view
@@ -0,0 +1,257 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE TypeApplications #-}++module Data.TimelineTest where++import Control.Applicative (liftA2)+import Control.Monad.Trans.Writer.CPS (execWriter, tell)+import Data.ByteString.Lazy qualified as LBS+import Data.Functor.WithIndex (imap)+import Data.Hashable+import Data.Map.Strict qualified as Map+import Data.Maybe (catMaybes, isJust, isNothing)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import Data.Time+ ( UTCTime (UTCTime),+ addUTCTime,+ fromGregorian,+ secondsToDiffTime,+ secondsToNominalDiffTime,+ )+import Data.Timeline+import Data.Timeline.Hedgehog (gen)+import Hedgehog (MonadGen, forAll, property, (===))+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range+import Test.Tasty (TestName, TestTree)+import Test.Tasty.Golden (goldenVsString)+import Test.Tasty.HUnit (testCase, (@=?), (@?=))+import Test.Tasty.Hedgehog (testProperty)++test_makeRecord :: [TestTree]+test_makeRecord =+ [ testProperty "it's always valid to have no effective-to" $ property $ do+ t <- forAll genUTCTime+ isJust (makeRecord @UTCTime @Int t Nothing 1) === True,+ testProperty "effectiveFrom must be less than effective-to" $ property $ do+ t1 <- forAll genUTCTime+ t2 <- forAll genUTCTime+ let tMin = min t1 t2+ tMax = max t1 t2+ if t1 == t2+ then isNothing (makeRecord @UTCTime @Int t1 (Just t2) 1) === True+ else isJust (makeRecord @UTCTime @Int tMin (Just tMax) 1) === True+ ]++test_fromRecords :: [TestTree]+test_fromRecords =+ [ testCase "empty input" $+ fromRecords @UTCTime @Int [] @?= Right (pure Nothing),+ testCase'+ "one change"+ [ makeRecord @UTCTime @Int+ (UTCTime (fromGregorian 2023 1 26) 7200)+ Nothing+ 100+ ],+ testCase'+ "one change, with effective to"+ [ makeRecord @UTCTime @Int+ (UTCTime (fromGregorian 2023 1 26) 7200)+ (Just $ UTCTime (fromGregorian 2023 2 28) 0)+ 100+ ],+ testCase'+ "all non-overlapping situations together"+ [ makeRecord @UTCTime @Int+ (UTCTime (fromGregorian 2023 1 26) 7200)+ (Just $ UTCTime (fromGregorian 2023 2 28) 0)+ 100,+ makeRecord @UTCTime @Int+ (UTCTime (fromGregorian 2023 3 1) 0)+ (Just $ UTCTime (fromGregorian 2023 4 1) 0)+ 200,+ makeRecord @UTCTime @Int+ (UTCTime (fromGregorian 2023 4 1) 0)+ Nothing+ 300,+ makeRecord @UTCTime @Int+ (UTCTime (fromGregorian 2023 5 1) 0)+ Nothing+ 400,+ makeRecord @UTCTime @Int+ (UTCTime (fromGregorian 2023 6 1) 0)+ Nothing+ 500+ ],+ testCase'+ "overlaps"+ [ makeRecord @UTCTime @Int+ (UTCTime (fromGregorian 2023 1 26) 7200)+ (Just $ UTCTime (fromGregorian 2023 2 28) 0)+ 100,+ makeRecord @UTCTime @Int+ (UTCTime (fromGregorian 2023 2 27) 0)+ (Just $ UTCTime (fromGregorian 2023 3 5) 0)+ 200,+ makeRecord @UTCTime @Int+ (UTCTime (fromGregorian 2023 3 1) 0)+ Nothing+ 300+ ],+ testCase'+ "two groups of overlap"+ [ makeRecord @UTCTime @Int+ (UTCTime (fromGregorian 2023 1 26) 7200)+ (Just $ UTCTime (fromGregorian 2023 2 28) 0)+ 100,+ makeRecord @UTCTime @Int+ (UTCTime (fromGregorian 2023 3 1) 0)+ (Just $ UTCTime (fromGregorian 2023 3 5) 0)+ 200,+ makeRecord @UTCTime @Int+ (UTCTime (fromGregorian 2023 3 3) 0)+ (Just $ UTCTime (fromGregorian 2023 3 4) 0)+ 300,+ makeRecord @UTCTime @Int+ (UTCTime (fromGregorian 2023 3 6) 0)+ (Just $ UTCTime (fromGregorian 2023 3 8) 0)+ 400,+ makeRecord @UTCTime @Int+ (UTCTime (fromGregorian 2023 3 8) 0)+ (Just $ UTCTime (fromGregorian 2023 3 15) 0)+ 500,+ makeRecord @UTCTime @Int+ (UTCTime (fromGregorian 2023 3 14) 0)+ Nothing+ 600+ ]+ ]+ where+ testCase' :: (Show a) => TestName -> [Maybe (Record UTCTime a)] -> TestTree+ testCase' name = buildGoldenTest pretty name . fromRecords . catMaybes++ pretty (Left overlaps) = prettyOverlaps overlaps+ pretty (Right timeline) = prettyTimeline timeline++test_peek :: [TestTree]+test_peek =+ [ testCase "constant" $ 1 @=? peek @UTCTime @Int (pure 1) (UTCTime (fromGregorian 2023 1 26) 0),+ testCase "before first change" $+ 1+ @=? peek @UTCTime @Int+ (Timeline 1 (Map.singleton (UTCTime (fromGregorian 2023 1 16) 0) 2))+ (UTCTime (fromGregorian 2023 1 15) 0),+ testCase "between changes" $+ 2+ @=? peek @UTCTime @Int+ ( Timeline+ 1+ [ (UTCTime (fromGregorian 2023 1 16) 0, 2),+ (UTCTime (fromGregorian 2023 1 19) 0, 3)+ ]+ )+ (UTCTime (fromGregorian 2023 1 18) 0),+ testCase "at the last change" $+ 3+ @=? peek @UTCTime @Int+ ( Timeline+ 1+ [ (UTCTime (fromGregorian 2023 1 16) 0, 2),+ (UTCTime (fromGregorian 2023 1 19) 0, 3)+ ]+ )+ (UTCTime (fromGregorian 2023 1 19) 0),+ testCase "after all changes" $+ 3+ @=? peek @UTCTime @Int+ ( Timeline+ 1+ [ (UTCTime (fromGregorian 2023 1 16) 0, 2),+ (UTCTime (fromGregorian 2023 1 19) 0, 3)+ ]+ )+ (UTCTime (fromGregorian 2023 1 20) 0)+ ]++-- The purpose of the first testProperty is to verify this rewrite rule+-- suggested by hlint is legal. (We are testing if the Applicative instance is correct)+{-# ANN test_apply ("HLint: ignore Use <$>" :: String) #-}+test_apply :: [TestTree]+test_apply =+ [ testProperty "pure f <*> x === f <$> x" $+ property $ do+ timeline <- forAll $ gen genUTCTime (Gen.int (Range.linear 0 1000))+ fmap (+ 1) timeline === (pure (+ 1) <*> timeline),+ testProperty "combined timeline" $+ property $ do+ t1 <- forAll $ gen genUTCTime (Gen.int (Range.linear 0 100))+ t2 <- forAll $ gen genUTCTime (Gen.int (Range.linear (-100) 0))+ let combined = liftA2 (+) t1 t2+ -- check the size+ changes t1 `Set.union` changes t2 === changes combined+ -- for random time+ time <- forAll genUTCTime+ peek t1 time + peek t2 time === peek combined time+ -- for the times that changes happen+ let timepoints = Set.toList $ changes combined+ zipWith (+) (fmap (peek t1) timepoints) (fmap (peek t2) timepoints) === fmap (peek combined) timepoints+ ]++test_imap :: [TestTree]+test_imap =+ [ testProperty "when ignoring the range, it works the same as fmap" $ property $ do+ tl <- forAll $ gen genUTCTime (Gen.int (Range.constant 0 1000))+ imap (const (+ 1)) tl === fmap (+ 1) tl,+ testCase "check the time ranges" $ do+ let t1 = UTCTime (fromGregorian 2023 1 16) 0+ t2 = UTCTime (fromGregorian 2023 1 19) 0+ timeline =+ Timeline @UTCTime @Int+ 1+ [ (t1, 2),+ (t2, 3)+ ]+ result = execWriter . sequenceA $ imap (\range _ -> tell @[TimeRange UTCTime] [range]) timeline+ result+ @?= [ TimeRange Nothing (Just t1),+ TimeRange (Just t1) (Just (addUTCTime (secondsToNominalDiffTime 259200) t1)),+ TimeRange (Just t2) Nothing+ ],+ testProperty "law: imap f . imap g === imap (\\i -> f i . g i)" $ property $ do+ tl <- forAll $ gen genUTCTime (Gen.int (Range.constant 0 1000))+ let hashTimeRange :: TimeRange UTCTime -> Int+ hashTimeRange TimeRange {from, to} = hash (show from) `hashWithSalt` show to+ f :: TimeRange UTCTime -> Int -> Int+ f tr x = hashTimeRange tr + x+ g :: TimeRange UTCTime -> Int -> Int+ g tr x = hashTimeRange tr - x+ (imap f . imap g) tl === imap (\i -> f i . g i) tl,+ testProperty "law: imap (\\_ a -> a) === id" $ property $ do+ tl <- forAll $ gen genUTCTime (Gen.int (Range.constant 0 1000))+ imap (\_ a -> a) tl === tl+ ]++buildGoldenTest :: (a -> Text) -> TestName -> a -> TestTree+buildGoldenTest pretty name value =+ goldenVsString+ name+ ("test/golden/" <> fmap (\ch -> if ch == ' ' then '_' else ch) name <> ".txt")+ $ pure . LBS.fromStrict . T.encodeUtf8 . pretty+ $ value++-- | A 'UTCTime' generator+genUTCTime :: (MonadGen m) => m UTCTime+genUTCTime = do+ y <- toInteger <$> Gen.int (Range.constant 2000 2030)+ m <- Gen.int (Range.constant 1 12)+ d <- Gen.int (Range.constant 1 28)+ let day = fromGregorian y m d+ secs <- toInteger <$> Gen.int (Range.constant 0 86401)+ let diff = secondsToDiffTime secs+ pure $ UTCTime day diff
+ test/Main.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-}
+ test/golden/all_non-overlapping_situations_together.txt view
@@ -0,0 +1,10 @@++----------Timeline--Start-------------+initial value: Nothing+since 2023-01-26 02:00:00 UTC: Just 100+since 2023-02-28 00:00:00 UTC: Nothing+since 2023-03-01 00:00:00 UTC: Just 200+since 2023-04-01 00:00:00 UTC: Just 300+since 2023-05-01 00:00:00 UTC: Just 400+since 2023-06-01 00:00:00 UTC: Just 500+----------Timeline--End---------------
+ test/golden/one_change,_with_effective_to.txt view
@@ -0,0 +1,6 @@++----------Timeline--Start-------------+initial value: Nothing+since 2023-01-26 02:00:00 UTC: Just 100+since 2023-02-28 00:00:00 UTC: Nothing+----------Timeline--End---------------
+ test/golden/one_change.txt view
@@ -0,0 +1,5 @@++----------Timeline--Start-------------+initial value: Nothing+since 2023-01-26 02:00:00 UTC: Just 100+----------Timeline--End---------------
+ test/golden/overlaps.txt view
@@ -0,0 +1,6 @@+Here are 1 group(s) of overlapping records+--------------------+2023-01-26 02:00:00 UTC ~ Just 2023-02-28 00:00:00 UTC: 100+2023-02-27 00:00:00 UTC ~ Just 2023-03-05 00:00:00 UTC: 200+2023-03-01 00:00:00 UTC ~ Nothing: 300+--------------------
+ test/golden/two_groups_of_overlap.txt view
@@ -0,0 +1,8 @@+Here are 2 group(s) of overlapping records+--------------------+2023-03-01 00:00:00 UTC ~ Just 2023-03-05 00:00:00 UTC: 200+2023-03-03 00:00:00 UTC ~ Just 2023-03-04 00:00:00 UTC: 300+--------------------+2023-03-08 00:00:00 UTC ~ Just 2023-03-15 00:00:00 UTC: 500+2023-03-14 00:00:00 UTC ~ Nothing: 600+--------------------
+ timeline.cabal view
@@ -0,0 +1,71 @@+cabal-version: 2.2+name: timeline+version: 0.1.0.0+synopsis:+ Data type representing a piecewise-constant function over time++description:+ Provides data types and related function to make handling+ timelines easier. Please see the README on GitHub at+ <https://github.com/bellroy/timeline>++license: BSD-3-Clause+license-file: LICENSE+author: Bellroy Tech Team <haskell@bellroy.com>+maintainer: Bellroy Tech Team <haskell@bellroy.com>+category: Development+build-type: Simple+tested-with: GHC ==8.10.7 || ==9.2.6 || ==9.4.4+extra-source-files:+ CHANGELOG.md+ README.md+ test/golden/*.txt++source-repository head+ type: git+ location: https://github.com/bellroy/timeline.git++common deps+ build-depends:+ , base >=4.14.3 && <4.18+ , containers >=0.6.5 && <0.7+ , hedgehog >=1.1 && <1.3+ , indexed-traversable >=0.1.2 && <0.2+ , semigroupoids >=5.3.7 && <5.4+ , template-haskell >=2.16.0 && <2.20+ , text >=1.2.4.1 && <2.1+ , th-compat >=0.1.4 && <0.2+ , time >=1.9.3 && <1.13++library+ import: deps+ hs-source-dirs: src/+ exposed-modules:+ Data.Timeline+ Data.Timeline.Hedgehog++ default-language: Haskell2010+ ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-unused-imports++test-suite tests+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ other-modules: Data.TimelineTest+ default-language: Haskell2010+ build-tool-depends: tasty-discover:tasty-discover >=4.2 && <5.1+ build-depends:+ , base >=4.14.3 && <4.18+ , bytestring >=0.10 && <0.12+ , containers >=0.6.5 && <0.7+ , hashable ^>=1.4.2.0+ , hedgehog >=1.1 && <1.3+ , indexed-traversable ^>=0.1.2+ , tasty ^>=1.4.3+ , tasty-golden ^>=2.3.5+ , tasty-hedgehog >=1.2.0.0+ , tasty-hunit ^>=0.10.0.3+ , text >=1.2.4.1 && <2.1+ , time >=1.9.3 && <1.13+ , timeline+ , transformers ^>=0.5.6.2