From 02ceb45a2f77ddcd3b4d75d200d4915b9f70bbe6 Mon Sep 17 00:00:00 2001 From: Joscha Date: Wed, 4 Apr 2018 19:02:21 +0000 Subject: [PATCH] Add Deadline and clean up date expressions --- src/TaskMachine/DateExpr.hs | 48 +++++++++++++++++++-- src/TaskMachine/Deadline.hs | 83 +++++++++++++++++++++++++++++++++++++ 2 files changed, 127 insertions(+), 4 deletions(-) create mode 100644 src/TaskMachine/Deadline.hs diff --git a/src/TaskMachine/DateExpr.hs b/src/TaskMachine/DateExpr.hs index 39716b2..a2e3926 100644 --- a/src/TaskMachine/DateExpr.hs +++ b/src/TaskMachine/DateExpr.hs @@ -1,10 +1,21 @@ {-# LANGUAGE OverloadedStrings #-} +-- | Parse and evaluate day-based expressions. +-- An expression can be evaluated for any given day. +-- +-- Evaluated expressions return 'Nothing' on impossible mathematical +-- operations, for example division by 0. +-- +-- For 'BoolExpr's, use the 'evalBoolExpr'' variant to automatically turn +-- 'Nothing' into 'False'. + module TaskMachine.DateExpr ( BoolExpr , parseBoolExpr , evalBoolExpr + , evalBoolExpr' , findNext + , findWithin , IntExpr , parseIntExpr , evalIntExpr @@ -25,6 +36,7 @@ import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L import Text.Megaparsec.Expr +-- | An expression that returns a 'Bool' when evaluated. data BoolExpr = BValue Bool | BStatement DateStatement @@ -43,6 +55,7 @@ data DateStatement | IsEaster -- same as: easter == 0 deriving (Show) +-- | An expression that returns an 'Integer' when evaluated. data IntExpr = IValue Integer | ISDate SpecialDate @@ -66,22 +79,39 @@ data SpecialDate | SEaster deriving (Show) +-- | Parse a 'BoolExpr' from a string. parseBoolExpr :: String -> Maybe BoolExpr parseBoolExpr = parseMaybe boolExpr +-- | Parse an 'IntExpr' from a string. parseIntExpr :: String -> Maybe IntExpr parseIntExpr = parseMaybe intExpr -findNext :: BoolExpr -> Day -> Int -> Maybe Day -findNext expr start duration = +-- | Find the next day where the expression evaluates to @True@. +-- If no day could be found, returns @Nothing@. +-- +-- This function uses 'evalBoolExpr'' to evaluate boolean expressions. +findNext :: Day -> Int -> BoolExpr -> Maybe Day +findNext start duration expr = let possibleDays = take duration $ iterate (addDays 1) start - checkDay = fromMaybe False . evalBoolExpr expr - in find checkDay possibleDays + in find (evalBoolExpr' expr) possibleDays + +-- | Returns a list of days where the expression evaluates to @True@. +-- +-- This function uses 'evalBoolExpr'' to evaluate boolean expressions. +findWithin :: Day -> Int -> BoolExpr -> [Day] +findWithin start duration expr = + let possibleDays = take duration $ iterate (addDays 1) start + in filter (evalBoolExpr' expr) possibleDays {- - Evaluating expressions -} +-- | Evaluates a 'BoolExpr' for a given day. +-- +-- Returns @Nothing@ if the expression contains any 'IntExpr' +-- that evaluates to @Nothing@ (i. e. contains a mathematical impossibility). evalBoolExpr :: BoolExpr -> Day -> Maybe Bool evalBoolExpr (BValue v) _ = pure v evalBoolExpr (BStatement s) d = pure $ evalDateStatement s d @@ -93,6 +123,13 @@ evalBoolExpr (BEqual a b) d = (==) <$> evalIntExpr a d <*> evalIntExpr b d evalBoolExpr (BGreater a b) d = (>) <$> evalIntExpr a d <*> evalIntExpr b d evalBoolExpr (BLess a b) d = (<) <$> evalIntExpr a d <*> evalIntExpr b d +-- | A variant of 'evalBoolExpr' that evaluates to False when the +-- result of the evaluation is @Nothing@. +-- +-- @'evalBoolExpr'' expr = 'fromMaybe' 'False' . 'evalBoolExpr' expr@ +evalBoolExpr' :: BoolExpr -> Day -> Bool +evalBoolExpr' expr = fromMaybe False . evalBoolExpr expr + evalDateStatement :: DateStatement -> Day -> Bool evalDateStatement IsLeapYear d = isLeapYear $ year d evalDateStatement IsWeekend d = weekday d `elem` [6,7] @@ -107,6 +144,9 @@ unlessSecondIsZero f a b d = do guard $ y /= 0 return $ f x y +-- | Evaluates an 'IntExpr' for a given day. +-- +-- Returns a @Nothing@ when a division by 0 or modulo 0 occurs. evalIntExpr :: IntExpr -> Day -> Maybe Integer evalIntExpr (IValue v) _ = pure v evalIntExpr (ISDate s) d = pure $ evalSpecialDate s d diff --git a/src/TaskMachine/Deadline.hs b/src/TaskMachine/Deadline.hs new file mode 100644 index 0000000..b6190e8 --- /dev/null +++ b/src/TaskMachine/Deadline.hs @@ -0,0 +1,83 @@ +-- | Tasks and events can have one or multiple deadlines. +-- +-- This module contains a representation for single deadlines, +-- and some useful functions for calculating things with them. + +module TaskMachine.Deadline + ( Deadline(..) + , Duration + -- * Calculations + , relevant + , isRelevant + , nextDeadlines + , relevant' + , isRelevant' + , nextDeadlines' + ) where + +import Data.Maybe + +import Data.Time.Calendar + +import qualified TaskMachine.DateExpr as TM + +-- | Duration of a task or event in days. +-- +-- A duration of 1 means one day. +-- Because of this, 'Duration' values __must always be greater than 0__. +type Duration = Int + +-- | A way to represent a deadline, either as a fixed date or using a formula. +data Deadline + = DFixed Day (Maybe Duration) + | DExpression TM.BoolExpr Duration + +-- | Find the next date of the 'Deadline' that's important for a certain day. +-- This returns a 'Just' when the day lies within the duration specified. +-- +-- If no duration is specified in a 'DFixed' deadline, all days before the deadline, +-- including the deadline itself, are important (i. e. the duration is infinite). +relevant :: Day -> Deadline -> Maybe Day +relevant today (DExpression expr duration) = TM.findNext today duration expr +relevant today (DFixed day Nothing) + | diffDays day today >= 0 = Just day + | otherwise = Nothing +relevant today (DFixed day (Just duration)) + | diff >= 0 && diff < toInteger duration = Just day + | otherwise = Nothing + where diff = diffDays day today + +-- | A version of 'relevant' modified to take a list of Deadlines. +relevant' :: Day -> [Deadline] -> Maybe Day +relevant' today deadlines = + let relevants = mapMaybe (relevant today) deadlines + in case relevants of + [] -> Nothing + days -> Just $ minimum days + + + +-- | Whether the 'Deadline' is relevant on the current day or not. +-- +-- This function works like 'relevant', only that the actual date calculated is irrelevant. +-- +-- @'isRelevant' day = 'isJust' . 'relevant' day@ +isRelevant :: Day -> Deadline -> Bool +isRelevant day = isJust . relevant day -- Hey, this even reads like English! :D + +-- | A version of 'isRelevant' modified to take a list of Deadlines. +isRelevant' :: Day -> [Deadline] -> Bool +isRelevant' day = any (isRelevant day) + +-- | Calculate all occurrences of this deadline within the duration given. +nextDeadlines :: Day -> Duration -> Deadline -> [Day] +nextDeadlines start duration (DFixed day _) + | diff >= 0 && diff < toInteger duration = [day] + | otherwise = [] + where diff = diffDays day start +nextDeadlines start duration (DExpression expr _) = + TM.findWithin start duration expr + +-- | A version of 'nextDeadlines' modified to take a list of Deadlines. +nextDeadlines' :: Day -> Duration -> [Deadline] -> [Day] +nextDeadlines' start duration = concatMap (nextDeadlines start duration)