114 lines
3.5 KiB
Haskell
114 lines
3.5 KiB
Haskell
module DateExpr
|
|
( BoolExpr
|
|
, parseBoolExpr
|
|
, firstMatchingDay
|
|
, evalBoolExpr
|
|
) where
|
|
|
|
import Data.List
|
|
import Data.Time.Calendar
|
|
import Data.Time.Calendar.WeekDate
|
|
import Data.Time.Calendar.MonthDay
|
|
import Data.Time.Calendar.Easter
|
|
import Text.Parsec
|
|
|
|
data BoolExpr = BValue Bool
|
|
| BStatement DateStatement
|
|
| BLeapYear
|
|
| BNot BoolExpr
|
|
| BAnd BoolExpr BoolExpr
|
|
| BOr BoolExpr BoolExpr
|
|
| BEq IntExpr IntExpr
|
|
| BGt IntExpr IntExpr
|
|
| BLt IntExpr IntExpr
|
|
|
|
data IntExpr = IValue Integer
|
|
| IDate SpecialDate
|
|
| INeg IntExpr
|
|
| IAdd IntExpr IntExpr
|
|
| IMul IntExpr IntExpr
|
|
| IDiv IntExpr IntExpr -- div, not quot!
|
|
| IMod IntExpr IntExpr -- mod, not rem!
|
|
|
|
data DateStatement = IsLeapYear
|
|
| IsWeekend
|
|
|
|
data SpecialDate = SJulianDay
|
|
| SYear | SMonth | SDay
|
|
| SDayOfYear
|
|
| SDayOfWeek
|
|
| SYearCount
|
|
| SMonthCount
|
|
| SEaster
|
|
|
|
{-
|
|
- Evaluating expressions
|
|
-}
|
|
|
|
firstMatchingDay :: BoolExpr -> Int -> Day -> Maybe Day
|
|
firstMatchingDay expr duration = find (evalBoolExpr expr) . take duration . iterate (addDays 1)
|
|
|
|
evalBoolExpr :: BoolExpr -> Day -> Bool
|
|
evalBoolExpr (BValue v) _ = v
|
|
evalBoolExpr (BStatement s) d = evalDateStatement s d
|
|
evalBoolExpr (BNot a) d = not $ evalBoolExpr a d
|
|
evalBoolExpr (BAnd a b) d = evalBoolExpr a d && evalBoolExpr b d
|
|
evalBoolExpr (BOr a b) d = evalBoolExpr a d || evalBoolExpr b d
|
|
evalBoolExpr (BEq a b) d = evalIntExpr a d == evalIntExpr b d
|
|
evalBoolExpr (BGt a b) d = evalIntExpr a d > evalIntExpr b d
|
|
evalBoolExpr (BLt a b) d = evalIntExpr a d < evalIntExpr b d
|
|
|
|
evalIntExpr :: IntExpr -> Day -> Integer
|
|
evalIntExpr (IValue v) _ = v
|
|
evalIntExpr (IDate s) d = evalSpecialDate s d
|
|
evalIntExpr (INeg a) d = - evalIntExpr a d
|
|
evalIntExpr (IAdd a b) d = evalIntExpr a d + evalIntExpr b d
|
|
evalIntExpr (IMul a b) d = evalIntExpr a d * evalIntExpr b d
|
|
evalIntExpr (IDiv a b) d = evalIntExpr a d `div` evalIntExpr b d
|
|
evalIntExpr (IMod a b) d = evalIntExpr a d `mod` evalIntExpr b d
|
|
|
|
evalDateStatement :: DateStatement -> Day -> Bool
|
|
evalDateStatement IsLeapYear d = isLeapYear $ year d
|
|
evalDateStatement IsWeekend d = weekday d `elem` [6,7]
|
|
|
|
evalSpecialDate :: SpecialDate -> Day -> Integer
|
|
evalSpecialDate SJulianDay d = julian d
|
|
evalSpecialDate SYear d = year d
|
|
evalSpecialDate SMonth d = month d
|
|
evalSpecialDate SDay d = day d
|
|
evalSpecialDate SDayOfYear d = yearday d
|
|
evalSpecialDate SDayOfWeek d = weekday d
|
|
evalSpecialDate SYearCount d = ((yearday d - 1) `div` 7) + 1
|
|
evalSpecialDate SMonthCount d = ((day d - 1) `div` 7) + 1
|
|
evalSpecialDate SEaster d = diffDays d $ orthodoxEaster $ year d
|
|
|
|
{-
|
|
- Helper functions for evaluation
|
|
-}
|
|
|
|
julian :: Day -> Integer
|
|
julian = flip diffDays (fromGregorian 1858 11 17)
|
|
|
|
year :: Day -> Integer
|
|
year d = let (r,_,_) = toGregorian d in r
|
|
|
|
month :: Day -> Integer
|
|
month d = let (_,r,_) = toGregorian d in toInteger r
|
|
|
|
day :: Day -> Integer
|
|
day d = let (_,_,r) = toGregorian d in toInteger r
|
|
|
|
weekday :: Day -> Integer
|
|
weekday d = let (_,_,r) = toWeekDate d in toInteger r
|
|
|
|
yearday :: Day -> Integer
|
|
yearday day = let (y,m,d) = toGregorian day
|
|
dayofyear = monthAndDayToDayOfYear (isLeapYear y) m d
|
|
in toInteger dayofyear
|
|
|
|
{-
|
|
- Parsing BoolExpr
|
|
-}
|
|
|
|
parseBoolExpr :: String -> Either ParseError BoolExpr
|
|
parseBoolExpr = undefined
|