Clean up DateExpr module

This commit is contained in:
Joscha 2017-12-11 18:56:11 +00:00
parent 28a46b4a86
commit cf6424b186

View file

@ -1,12 +1,16 @@
module DateExpr module DateExpr
( BoolExpr ( BoolExpr
, IntExpr , parseBoolExpr
, firstMatchingDay
, evalBoolExpr
) where ) where
import Data.List
import Data.Time.Calendar import Data.Time.Calendar
import Data.Time.Calendar.WeekDate import Data.Time.Calendar.WeekDate
import Data.Time.Calendar.MonthDay import Data.Time.Calendar.MonthDay
import Data.Time.Calendar.Easter import Data.Time.Calendar.Easter
import Text.Parsec
data BoolExpr = BValue Bool data BoolExpr = BValue Bool
| BStatement DateStatement | BStatement DateStatement
@ -37,6 +41,13 @@ data SpecialDate = SJulianDay
| SMonthCount | SMonthCount
| SEaster | 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 :: BoolExpr -> Day -> Bool
evalBoolExpr (BValue v) _ = v evalBoolExpr (BValue v) _ = v
evalBoolExpr (BStatement s) d = evalDateStatement s d evalBoolExpr (BStatement s) d = evalDateStatement s d
@ -71,6 +82,10 @@ evalSpecialDate SYearCount d = ((yearday d - 1) `div` 7) + 1
evalSpecialDate SMonthCount d = ((day d - 1) `div` 7) + 1 evalSpecialDate SMonthCount d = ((day d - 1) `div` 7) + 1
evalSpecialDate SEaster d = diffDays d $ orthodoxEaster $ year d evalSpecialDate SEaster d = diffDays d $ orthodoxEaster $ year d
{-
- Helper functions for evaluation
-}
julian :: Day -> Integer julian :: Day -> Integer
julian = flip diffDays (fromGregorian 1858 11 17) julian = flip diffDays (fromGregorian 1858 11 17)
@ -90,3 +105,10 @@ yearday :: Day -> Integer
yearday day = let (y,m,d) = toGregorian day yearday day = let (y,m,d) = toGregorian day
dayofyear = monthAndDayToDayOfYear (isLeapYear y) m d dayofyear = monthAndDayToDayOfYear (isLeapYear y) m d
in toInteger dayofyear in toInteger dayofyear
{-
- Parsing BoolExpr
-}
parseBoolExpr :: String -> Either ParseError BoolExpr
parseBoolExpr = undefined