diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,4 @@ +# Changelog + +## 0.1.0.0 +- Open source the timeline library we use internally at Bellroy diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 diff --git a/src/Data/Timeline.hs b/src/Data/Timeline.hs new file mode 100644 --- /dev/null +++ b/src/Data/Timeline.hs @@ -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 diff --git a/src/Data/Timeline/Hedgehog.hs b/src/Data/Timeline/Hedgehog.hs new file mode 100644 --- /dev/null +++ b/src/Data/Timeline/Hedgehog.hs @@ -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 diff --git a/test/Data/TimelineTest.hs b/test/Data/TimelineTest.hs new file mode 100644 --- /dev/null +++ b/test/Data/TimelineTest.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-} diff --git a/test/golden/all_non-overlapping_situations_together.txt b/test/golden/all_non-overlapping_situations_together.txt new file mode 100644 --- /dev/null +++ b/test/golden/all_non-overlapping_situations_together.txt @@ -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--------------- diff --git a/test/golden/one_change,_with_effective_to.txt b/test/golden/one_change,_with_effective_to.txt new file mode 100644 --- /dev/null +++ b/test/golden/one_change,_with_effective_to.txt @@ -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--------------- diff --git a/test/golden/one_change.txt b/test/golden/one_change.txt new file mode 100644 --- /dev/null +++ b/test/golden/one_change.txt @@ -0,0 +1,5 @@ + +----------Timeline--Start------------- +initial value: Nothing +since 2023-01-26 02:00:00 UTC: Just 100 +----------Timeline--End--------------- diff --git a/test/golden/overlaps.txt b/test/golden/overlaps.txt new file mode 100644 --- /dev/null +++ b/test/golden/overlaps.txt @@ -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 +-------------------- diff --git a/test/golden/two_groups_of_overlap.txt b/test/golden/two_groups_of_overlap.txt new file mode 100644 --- /dev/null +++ b/test/golden/two_groups_of_overlap.txt @@ -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 +-------------------- diff --git a/timeline.cabal b/timeline.cabal new file mode 100644 --- /dev/null +++ b/timeline.cabal @@ -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 + + +license: BSD-3-Clause +license-file: LICENSE +author: Bellroy Tech Team +maintainer: Bellroy Tech Team +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