{-# LANGUAGE LambdaCase #-}
-- | Functions to evaluate conditional restrictions.
module ConditionalRestriction.Internal.Evaluate where
import ConditionalRestriction.Parse.AST
( ComparisonOp (Eq, Gt, GtEq, Lt, LtEq),
Condition (..),
ConditionalRestriction (..),
Expression (Expression),
OpeningHours (..),
RuleSequence (RuleSequence),
RuleType (Additional, Normal),
SelectorSequence
( TimeSel,
TwentyFourSeven,
WeekdaySel,
WeekdayTime
),
TimeSelector,
TimeSpan (..),
Token,
WeekdayRange (SingleDay, WdayRange),
WeekdaySelector,
)
import ConditionalRestriction.Parse.InputData
( ID,
Type (..),
Value (..),
)
import ConditionalRestriction.Result (Result (..))
import Data.Hourglass
( DateTime,
TimeOfDay (TimeOfDay),
WeekDay (Saturday, Sunday),
getWeekDay,
timeGetDate,
timeGetTimeOfDay,
)
import Data.List (nub)
-- | Plain text error message.
type ErrorMsg = String
-- | The 'result' function takes input data in the form of ('ID', 'Value') and a 'ConditionalRestriction' and returns
-- the result of that 'ConditionalRestriction' when applied to the input data given. If data needed for the evaluation
-- is missing or of the wrong type, it will return a list of error messages and a list of missing data types instead.
--
-- Note that this function will accept incomplete data if it is enough to evaluate the expression, but will always return
-- a complete list of needed data types.
result :: [(ID, Value)] -> ConditionalRestriction -> Result ([ErrorMsg], [(ID, Type)]) (Maybe Token)
result ds (ConditionalRestriction exprs) =
find_r (\(Expression _ conds) -> all_r (fulfills ds) conds) (reverse exprs) >>= \case
Nothing -> Ok Nothing
Just (Expression tok _) -> Ok $ Just tok
where
find_r f (x : xs) = case f x of
Ok True -> Ok $ Just x
Ok False -> find_r f xs
Err (msgs, needed) -> case find_r f xs of
Err (msgs', needed') -> Err (msgs ++ msgs', nub $ needed ++ needed')
Ok v -> Err (msgs, needed)
find_r f [] = Ok Nothing
all_r f (x : xs) = case f x of
Ok True -> all_r f xs
Ok False -> False <$ all_r f xs
Err (Left msg) -> case all_r f xs of
Ok _ -> Err ([msg], [])
Err (msgs, neededs) -> Err (msg : msgs, neededs)
Err (Right needed) -> case all_r f xs of
Ok _ -> Err ([], [needed])
Err (msgs, neededs) -> Err (msgs, needed : neededs)
all_r f [] = Ok True
-- | The 'fulfills' function takes input data in the form of ('ID', 'Value') and a 'Condition' and returns
-- whether that condition is fulfilled. If some data is missing, it will return the missing data 'ID' and 'Type'
-- and if the given data is of the wrong type, it will return an error message.
fulfills :: [(ID, Value)] -> Condition -> Result (Either ErrorMsg (ID, Type)) Bool
fulfills ds (OH oh) = case lookup "time" ds of
Just (VTime t) -> Ok $ timeIn t oh
Just _ -> Err . Left $ "Incorrect input type for time"
Nothing -> case oh of
OpeningHours [RuleSequence _ TwentyFourSeven (Just o)] -> Ok o
_ -> Err $ Right ("time", TTime)
fulfills ds (Comparison tok op val) = case lookup tok ds of
Just (VNum d) -> Ok $ case op of
Gt -> d > val
Lt -> d < val
GtEq -> d >= val
LtEq -> d <= val
Eq -> d == val
Just _ -> Err . Left $ "Incorrect input type for " ++ tok
Nothing -> Err $ Right (tok, TNum)
fulfills ds (Absolute tok) = case lookup tok ds of
Just (VBool b) -> Ok b
Just _ -> Err . Left $ "Incorrect input type for " ++ tok
Nothing -> Err $ Right (tok, TBool)
-- | The 'timeIn' function returns wheter a 'DateTime' is within given 'OpeningHours'. Unknown values count as not
-- within the opening hours.
timeIn :: DateTime -> OpeningHours -> Bool
timeIn t oh =
timeInSelector time (ohTimes oh !! fromEnum weekday)
|| timeExtendedInSelector time (ohTimes oh !! fromEnum previous_weekday)
where
date = timeGetDate t
time = timeGetTimeOfDay t
weekday = getWeekDay date
previous_weekday = if weekday == minBound then maxBound else pred weekday
ohTimes :: OpeningHours -> [TimeSelector]
ohTimes (OpeningHours rs) = foldr set_time_ranges [[] | _ <- range Sunday Saturday] (reverse rs)
where
set_time_ranges (RuleSequence t TwentyFourSeven (Just o)) = map (integrate t o [Span min_time max_time])
set_time_ranges (RuleSequence t (WeekdaySel wdrs) (Just o)) = mapDays (combineWeekdays wdrs) (integrate t o [Span min_time max_time])
set_time_ranges (RuleSequence t (TimeSel ts) (Just o)) = map (integrate t o ts)
set_time_ranges (RuleSequence t (WeekdayTime wdrs ts) (Just o)) = mapDays (combineWeekdays wdrs) (integrate t o ts)
set_time_ranges _ = id
min_time = TimeOfDay 00 00 00 0
max_time = TimeOfDay 23 59 59 999999999
integrate Normal = override
integrate Additional = combine
override True = const
override False = \_ -> const []
combine True = foldr addTimespan
combine False = foldr subtractTimespan
timeInSelector :: TimeOfDay -> TimeSelector -> Bool
timeInSelector t = any match_t
where
match_t (Moment t') = t' == t
match_t (Span t1 t2) = t >= t1 && (t <= t2 || t1 > t2)
timeExtendedInSelector :: TimeOfDay -> TimeSelector -> Bool
timeExtendedInSelector t = any match_t
where
match_t (Moment (TimeOfDay h' m' s' n')) = t == TimeOfDay (h' - 24) m' s' n'
match_t (Span t1 t2) | t1 > t2 = t <= t2
match_t (Span t1 (TimeOfDay h' m' s' n')) | h' >= 24 = t < TimeOfDay (h' - 24) m' s' n'
match_t _ = False
addTimespan :: TimeSpan -> TimeSelector -> TimeSelector
addTimespan ts sel = add_timespan (explicitExtended ts) (map explicitExtended sel)
where
add_timespan (Moment t) sel@(Moment t' : ts) | t == t' = sel
add_timespan (Moment t) (Moment t' : ts) = Moment t' : add_timespan (Moment t) ts
add_timespan (Moment t) sel@(Span t1 t2 : ts) | t >= t1 && t <= t2 = sel
add_timespan (Moment t) (Span t1 t2 : ts) = Span t1 t2 : add_timespan (Moment t) ts
add_timespan (Span t1 t2) (Moment t : ts) | t >= t1 && t <= t2 = Span t1 t2 : ts
add_timespan (Span t1 t2) (Moment t : ts) = Moment t : add_timespan (Span t1 t2) ts
add_timespan (Span ta1 ta2) (Span tb1 tb2 : ts) | (tb1 <= ta2 && tb2 > ta1) || (ta1 <= tb2 && ta2 > tb1) = -- where overlaps
Span (min ta1 tb1) (max ta2 tb2) : ts
add_timespan (Span ta1 ta2) (Span tb1 tb2 : ts) = Span tb1 tb2 : add_timespan (Span ta1 ta2) ts
add_timespan x [] = [x]
subtractTimespan :: TimeSpan -> TimeSelector -> TimeSelector
subtractTimespan ts sel = subtract_timespan (explicitExtended ts) (map explicitExtended sel)
where
subtract_timespan (Moment t) sel@(Moment t' : ts) | t == t' = ts
subtract_timespan (Moment t) (Moment t' : ts) = Moment t' : subtract_timespan (Moment t) ts
subtract_timespan (Moment t) sel@(Span t1 t2 : ts) | t >= t1 && t <= t2 = sel -- don't subtract single moments from time spans
subtract_timespan (Moment t) (Span t1 t2 : ts) = Span t1 t2 : subtract_timespan (Moment t) ts
subtract_timespan (Span t1 t2) (Moment t : ts) | t >= t1 && t <= t2 = subtract_timespan (Span t1 t2) ts
subtract_timespan (Span t1 t2) (Moment t : ts) = Moment t : subtract_timespan (Span t1 t2) ts
subtract_timespan (Span ta1 ta2) (Span tb1 tb2 : ts) | (tb1 < ta2 && tb2 > ta1) || (ta1 < tb2 && ta2 > tb1) =
Span (min ta1 tb1) (max ta1 tb1) : Span (min ta2 tb2) (max ta2 tb2) : ts
subtract_timespan (Span ta1 ta2) (Span tb1 tb2 : ts) | ta1 == tb1 && ta2 == tb2 = ts
subtract_timespan (Span ta1 ta2) (Span tb1 tb2 : ts) | ta1 == tb1 = Span (min ta2 tb2) (max ta2 tb2) : ts
subtract_timespan (Span ta1 ta2) (Span tb1 tb2 : ts) | ta2 == tb2 = Span (min ta1 tb1) (max ta1 tb1) : ts
subtract_timespan (Span ta1 ta2) (Span tb1 tb2 : ts) = Span tb1 tb2 : subtract_timespan (Span ta1 ta2) ts
subtract_timespan x [] = []
explicitExtended :: TimeSpan -> TimeSpan
explicitExtended (Span t1 t2@(TimeOfDay h m s n)) | t1 >= t2 = Span t1 (TimeOfDay (h + 24) m s n)
explicitExtended other = other
mapDays :: [WeekDay] -> (a -> a) -> [a] -> [a]
mapDays days f = zipWith (\d x -> (if d `elem` days then f x else x)) (range Sunday Saturday)
combineWeekdays :: WeekdaySelector -> [WeekDay]
combineWeekdays = nub . combine
where
combine (SingleDay day : wdrs) = day : combineWeekdays wdrs
combine (WdayRange from to : wdrs) = range from to ++ combineWeekdays wdrs
combine [] = []
range :: (Ord a, Enum a, Bounded a) => a -> a -> [a]
range a b | b < a = [a ..] ++ [minBound .. b]
range a b = [a .. b]