TimeSpan.hs

module Control.Scheduling.TimeSpan (expand, TimeSpan(..), start, end, stringsToSlots, timesFromStrings) where

import Data.Time
import Control.Lens ((^.), (.~), (<&>), set, view, makeLenses, makeFields)
import Data.List (unfoldr)

data TimeSpan = TimeSpan { _start :: UTCTime
                         , _end :: UTCTime
                         } deriving (Show, Eq, Ord)

makeLenses ''TimeSpan

stringsToSlots :: String -> String -> String -> String -> Integer -> Maybe [TimeSpan]
stringsToSlots sd ed st et sl = Just slots
  where
    days = daysFromStrings sd ed
    (st', et') = timesFromStrings st et
    ranges = [TimeSpan (UTCTime d st') (UTCTime d et') | d <- days]
    increment' = secondsToDiffTime $ 60 * sl :: DiffTime
    slots = concat $ map (expand increment') ranges

expand :: DiffTime -> TimeSpan -> [TimeSpan]
expand slotLength block = if s' > e then [n] else n:(expand slotLength block')
  where
    s = block ^. start
    e = block ^. end
    s' = s { utctDayTime=utctDayTime s + slotLength }
    n = TimeSpan s s'
    block' = TimeSpan s' e
  
daysFromStrings :: String -> String -> [Day]
daysFromStrings s e = ds
  where
    s' = parseTimeOrError True defaultTimeLocale "%Y-%-m-%-d" s :: Day
    e' = parseTimeOrError True defaultTimeLocale "%Y-%-m-%-d" e :: Day
    ds = unfoldr (\d -> if d > e' then Nothing else Just (d, (addDays 1 d))) s'

timesFromStrings :: String -> String -> (DiffTime, DiffTime)
timesFromStrings s e = (timeOfDayToTime s', timeOfDayToTime e')
  where
    s' = parseTimeOrError True defaultTimeLocale "%R" s :: TimeOfDay
    e' = parseTimeOrError True defaultTimeLocale "%R" e :: TimeOfDay