interval-patterns 0.3.0.0 → 0.3.0.1

raw patch · 3 files changed

+101/−1 lines, 3 files

Files

• CHANGELOG.md +4/−0
• interval-patterns.cabal +2/−1
• src/Data/Calendar.hs +95/−0

@@ -1,5 +1,9 @@ # Revision history for interval-patterns +## 0.3.0.1 - 2022-06-08++* expose `Data.Calendar` lol+ ## 0.3.0.0 - 2022-06-08  * new pattern synonym `(:---:) :: (Ord x) => Levitated x -> Levitated x -> Interval x`

@@ -1,6 +1,6 @@ cabal-version: 3.0 name: interval-patterns-version: 0.3.0.0+version: 0.3.0.1 author: Melanie Brown description: A library for easy manipulation of intervals according to their overlap. maintainer: brown.m@pm.me@@ -73,6 +73,7 @@     Data.Interval.Borel     Data.OneOrTwo     Data.Timeframe+    Data.Calendar  test-suite tests   import: interval-patterns

@@ -0,0 +1,95 @@+module Data.Calendar (+  module Data.Timeframe,+  Event,+  event,+  eventSize,+  Calendar (..),+  singleton,+  calendar,+  insert,+  (!?),+  (!),+  Data.Calendar.toList,+  happeningAt,+  coalesce,+  totalDuration,+) where++import Data.Interval.Layers (Layers)+import Data.Interval.Layers qualified as Layers+import Data.Map.Strict qualified as Map+import Data.Time.Compat+import Data.Timeframe++-- | An 'Event' is a collection of 'Timeframe's that keeps track of+-- how deeply a particular interval has been overlapped.+--+-- > type Event n = Layers UTCTime (Sum n)+type Event n = Layers UTCTime (Sum n)++-- | Make a new 'Event' from a 'Timeframe' with default thickness 1.+--+-- > event = eventSize 1+event :: (Num n) => Timeframe -> Event n+event = (`Layers.singleton` 1)++-- | Make an 'Event' with the given size from a 'Timeframe'.+eventSize :: (Num n) => n -> Timeframe -> Event n+eventSize n = (`Layers.singleton` Sum n)++-- | A 'Calendar' is a map from a given event type to durations.+newtype Calendar ev n = Calendar {getCalendar :: Map ev (Event n)}+  deriving (Eq, Ord, Show, Typeable)++instance (Ord ev, Num n) => Semigroup (Calendar ev n) where+  Calendar a <> Calendar b = Calendar (Map.unionWith (<>) a b)++instance (Ord ev, Num n) => Monoid (Calendar ev n) where+  mempty = Data.Calendar.empty++-- | The empty 'Calendar'.+empty :: Calendar ev n+empty = Calendar Map.empty++-- | Make a 'Calendar' from an 'Event'.+singleton :: (Ord ev, Num n) => ev -> Event n -> Calendar ev n+singleton ev cvg = Calendar (Map.singleton ev cvg)++-- | Make a 'Calendar' from a 'Timeframe'.+calendar :: (Ord ev, Num n) => ev -> Timeframe -> Calendar ev n+calendar ev tf = singleton ev (Layers.singleton tf 1)++-- | Insert an 'Event' of the given sort into a 'Calendar'.+insert :: (Ord ev, Num n) => ev -> Event n -> Calendar ev n -> Calendar ev n+insert ev cvg (Calendar c) = Calendar (Map.insertWith (<>) ev cvg c)++-- | Get the 'Event' corresponding to a given key, or 'Nothing' if the key is not present.+(!?) :: (Ord ev, Num n) => Calendar ev n -> ev -> Maybe (Event n)+Calendar c !? ev = c Map.!? ev++-- | Get the 'Event' corresponding to a given key, or 'mempty' if the key is not present.+(!) :: (Ord ev, Num n) => Calendar ev n -> ev -> Event n+Calendar c ! ev = c Map.!? ev ?: mempty++toList :: (Ord ev, Num n) => Calendar ev n -> [(ev, [(Interval UTCTime, n)])]+toList (Calendar c) = fmap getSum <<$>> Layers.toList <<$>> Map.assocs c++-- | What any how many events are happening at the given 'UTCTime' on this 'Calendar'?+happeningAt :: (Ord ev, Num n) => UTCTime -> Calendar ev n -> [(ev, n)]+happeningAt time (Data.Calendar.toList -> evs) =+  [(ev, n) | (ev, ns) <- evs, (_, n) <- filter (within time . fst) ns]++-- | Consider every kind of event the same, and only observe the overall 'Layers'.+coalesce :: (Ord ev, Num n) => Calendar ev n -> Event n+coalesce (Calendar c) = fold c++totalDuration :: forall ev n. (Ord ev, Real n) => ev -> Calendar ev n -> Maybe NominalDiffTime+totalDuration ev (Calendar c) = case c Map.!? ev of+  Nothing -> Just 0+  Just is -> foldr f (Just 0) (Layers.toList is)+ where+  f :: (Timeframe, Sum n) -> Maybe NominalDiffTime -> Maybe NominalDiffTime+  f _ Nothing = Nothing+  f (tf, Sum n) (Just x) = case (realToFrac n *) <$> duration tf of+    Nothing -> Nothing+    Just y -> Just (x + y)