85 lines
3.2 KiB
Haskell
85 lines
3.2 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}
|
|
|
|
module Utils.Occurences
|
|
( normalizeOccurences
|
|
) where
|
|
|
|
import ClassyPrelude
|
|
|
|
import Model.Types
|
|
import Utils
|
|
import Utils.Lens
|
|
|
|
import Control.Monad.Trans.Reader (runReader, Reader)
|
|
|
|
import Control.Monad.Trans.Except (ExceptT, throwE, runExceptT)
|
|
|
|
import qualified Data.Set as Set
|
|
|
|
import Data.Time
|
|
import Data.Time.Calendar.WeekDate
|
|
|
|
|
|
normalizeOccurences :: Occurences -> Occurences
|
|
-- ^
|
|
--
|
|
-- - Removes unnecessary exceptions
|
|
-- - Merges overlapping schedules
|
|
normalizeOccurences initial
|
|
| Left new <- runReader (runExceptT go) initial
|
|
= normalizeOccurences new
|
|
| otherwise
|
|
= initial
|
|
where
|
|
go :: ExceptT Occurences (Reader Occurences) ()
|
|
-- Find some inconsistency and `throwE` a version without it
|
|
go = do
|
|
scheduled <- view _occurencesScheduled
|
|
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 _occurencesScheduled $ mapMaybe (\b -> (,) <$> pure b <*> merge b) . Set.toList . Set.delete a
|
|
case merges of
|
|
[] -> return ()
|
|
((b, merged) : _) -> throwE =<< asks (over _occurencesScheduled $ Set.insert merged . Set.delete b . Set.delete a)
|
|
|
|
exceptions <- view _occurencesExceptions
|
|
forM_ exceptions $ \case
|
|
needle@ExceptNoOccur{..} -> do
|
|
let LocalTime{..} = exceptTime
|
|
(_, _, toEnum . (`mod` 7) -> localWeekDay) = toWeekDate localDay
|
|
needed <- views _occurencesScheduled . any $ \case
|
|
ScheduleWeekly{..} -> and
|
|
[ scheduleDayOfWeek == localWeekDay
|
|
, scheduleStart <= localTimeOfDay
|
|
, localTimeOfDay <= scheduleEnd
|
|
]
|
|
unless needed $
|
|
throwE =<< asks (over _occurencesExceptions $ 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 _occurencesScheduled . none $ \case
|
|
ScheduleWeekly{..} -> and
|
|
[ scheduleDayOfWeek == localWeekDay
|
|
, scheduleStart == exceptStart
|
|
, scheduleEnd == exceptEnd
|
|
]
|
|
unless needed $
|
|
throwE =<< asks (over _occurencesExceptions $ Set.filter (not . withinNeedle) . Set.delete needle)
|