89 lines
3.4 KiB
Haskell
89 lines
3.4 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}
|
|
|
|
module Utils.Occurrences
|
|
( normalizeOccurrences
|
|
) where
|
|
|
|
import ClassyPrelude
|
|
|
|
import Model.Types
|
|
import Utils
|
|
import Utils.Lens
|
|
|
|
import Control.Monad.Trans.Reader (runReader)
|
|
|
|
import Control.Monad.Trans.Except (ExceptT, throwE, runExceptT)
|
|
|
|
import qualified Data.Set as Set
|
|
|
|
import Data.Time
|
|
import Data.Time.Calendar.WeekDate
|
|
|
|
|
|
normalizeOccurrences :: Occurrences -> Occurrences
|
|
-- ^
|
|
--
|
|
-- - Removes unnecessary exceptions
|
|
-- - Merges overlapping schedules
|
|
normalizeOccurrences initial
|
|
| Left new <- runReader (runExceptT go) initial
|
|
= normalizeOccurrences new
|
|
| otherwise
|
|
= initial
|
|
where
|
|
go :: ExceptT Occurrences (Reader Occurrences) ()
|
|
-- Find some inconsistency and `throwE` a version without it
|
|
go = do
|
|
scheduled <- view _occurrencesScheduled
|
|
forM_ scheduled $ \case
|
|
a@ScheduleWeekly{} -> do
|
|
let
|
|
merge b@ScheduleWeekly{}
|
|
| scheduleDayOfWeek a == scheduleDayOfWeek b -- b starts during a
|
|
, scheduleStart a <= scheduleStart b
|
|
, scheduleEnd a >= scheduleStart b
|
|
= Just $ ScheduleWeekly (scheduleDayOfWeek a) (scheduleStart a) ((max `on` scheduleEnd) a b)
|
|
| scheduleDayOfWeek a == scheduleDayOfWeek b -- b ends during a
|
|
, scheduleStart a <= scheduleEnd b
|
|
, scheduleEnd a >= scheduleEnd b
|
|
= Just $ ScheduleWeekly (scheduleDayOfWeek a) ((min `on` scheduleStart) a b) (scheduleEnd a)
|
|
| otherwise
|
|
= Nothing
|
|
merge _ = Nothing
|
|
merges <- views _occurrencesScheduled $ mapMaybe (\b -> (b, ) <$> merge b) . Set.toList . Set.delete a
|
|
case merges of
|
|
[] -> return ()
|
|
((b, merged) : _) -> throwE =<< asks (over _occurrencesScheduled $ Set.insert merged . Set.delete b . Set.delete a)
|
|
|
|
exceptions <- view _occurrencesExceptions
|
|
forM_ exceptions $ \case
|
|
needle@ExceptNoOccur{..} -> do
|
|
let LocalTime{..} = exceptTime
|
|
(_, _, toEnum . (`mod` 7) -> localWeekDay) = toWeekDate localDay
|
|
needed <- views _occurrencesScheduled . any $ \case
|
|
ScheduleWeekly{..} -> and
|
|
[ scheduleDayOfWeek == localWeekDay
|
|
, scheduleStart <= localTimeOfDay
|
|
, localTimeOfDay <= scheduleEnd
|
|
]
|
|
unless needed $
|
|
throwE =<< asks (over _occurrencesExceptions $ Set.delete needle)
|
|
needle@ExceptOccur{..} -> do
|
|
let (_, _, toEnum . (`mod` 7) -> localWeekDay) = toWeekDate exceptDay
|
|
-- | Does this ExceptNoOccur target within needle?
|
|
withinNeedle ExceptNoOccur{..} = LocalTime exceptDay exceptStart <= exceptTime
|
|
&& exceptTime <= LocalTime exceptDay exceptEnd
|
|
withinNeedle _ = False
|
|
needed <- views _occurrencesScheduled . none $ \case
|
|
ScheduleWeekly{..} -> and
|
|
[ scheduleDayOfWeek == localWeekDay
|
|
, scheduleStart == exceptStart
|
|
, scheduleEnd == exceptEnd
|
|
]
|
|
unless needed $
|
|
throwE =<< asks (over _occurrencesExceptions $ Set.filter (not . withinNeedle) . Set.delete needle)
|