238 lines
6.9 KiB
Haskell
238 lines
6.9 KiB
Haskell
module DateExpr
|
|
( DateExpr
|
|
, parseDateExpr
|
|
, firstMatchingDay
|
|
, evalDateExpr
|
|
, daily
|
|
, weekly
|
|
) where
|
|
|
|
import Control.Applicative
|
|
import Control.Monad
|
|
import Data.List
|
|
import Data.Maybe
|
|
import Data.Time.Calendar
|
|
import Data.Time.Calendar.WeekDate
|
|
import Data.Time.Calendar.MonthDay
|
|
import Data.Time.Calendar.Easter
|
|
import Data.Void
|
|
import Text.Megaparsec
|
|
import Text.Megaparsec.Char
|
|
import qualified Text.Megaparsec.Char.Lexer as L
|
|
import Text.Megaparsec.Expr
|
|
|
|
type DateExpr = BoolExpr
|
|
|
|
data BoolExpr = BValue Bool
|
|
| BStatement DateStatement
|
|
| BNot BoolExpr
|
|
| BAnd BoolExpr BoolExpr
|
|
| BOr BoolExpr BoolExpr
|
|
| BEq IntExpr IntExpr
|
|
| BGt IntExpr IntExpr
|
|
| BLt IntExpr IntExpr
|
|
deriving (Show)
|
|
|
|
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!
|
|
deriving (Show)
|
|
|
|
data DateStatement = IsLeapYear
|
|
| IsWeekend
|
|
deriving (Show)
|
|
-- possible additions: IsEaster
|
|
|
|
data SpecialDate = SJulianDay
|
|
| SYear | SMonth | SDay
|
|
| SDayOfYear
|
|
| SDayOfWeek
|
|
| SYearCount
|
|
| SMonthCount
|
|
| SEaster
|
|
deriving (Show)
|
|
|
|
daily :: DateExpr
|
|
daily = BValue True
|
|
|
|
weekly :: DateExpr
|
|
weekly = BEq (IDate SDayOfWeek) (IValue 7)
|
|
|
|
{-
|
|
- Evaluating expressions
|
|
-}
|
|
|
|
evalDateExpr :: DateExpr -> Day -> Bool
|
|
evalDateExpr expr = fromMaybe False . evalBoolExpr expr
|
|
|
|
firstMatchingDay :: DateExpr -> Int -> Day -> Maybe Day
|
|
firstMatchingDay expr duration = find (evalDateExpr expr)
|
|
. take duration . iterate (addDays 1)
|
|
|
|
evalBoolExpr :: BoolExpr -> Day -> Maybe Bool
|
|
evalBoolExpr (BValue v) _ = Just v
|
|
evalBoolExpr (BStatement s) d = Just $ evalDateStatement s d
|
|
evalBoolExpr (BNot a) d = not <$> evalBoolExpr a d
|
|
evalBoolExpr (BAnd a b) d = liftA2 (&&) (evalBoolExpr a d) (evalBoolExpr b d)
|
|
evalBoolExpr (BOr a b) d = liftA2 (||) (evalBoolExpr a d) (evalBoolExpr b d)
|
|
evalBoolExpr (BEq a b) d = liftA2 (==) (evalIntExpr a d) (evalIntExpr b d)
|
|
evalBoolExpr (BGt a b) d = liftA2 (>) (evalIntExpr a d) (evalIntExpr b d)
|
|
evalBoolExpr (BLt a b) d = liftA2 (<) (evalIntExpr a d) (evalIntExpr b d)
|
|
|
|
evalIntExpr :: IntExpr -> Day -> Maybe Integer
|
|
evalIntExpr (IValue v) _ = Just v
|
|
evalIntExpr (IDate s) d = Just $ evalSpecialDate s d
|
|
evalIntExpr (INeg a) d = negate <$> evalIntExpr a d
|
|
evalIntExpr (IAdd a b) d = liftA2 (+) (evalIntExpr a d) (evalIntExpr b d)
|
|
evalIntExpr (IMul a b) d = liftA2 (*) (evalIntExpr a d) (evalIntExpr b d)
|
|
evalIntExpr (IDiv a b) d = do
|
|
x <- evalIntExpr a d
|
|
y <- evalIntExpr b d
|
|
guard $ y /= 0
|
|
return $ x `div` y
|
|
evalIntExpr (IMod a b) d = do
|
|
x <- evalIntExpr a d
|
|
y <- evalIntExpr b d
|
|
guard $ y /= 0
|
|
return $ x `mod` y
|
|
|
|
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 Expressions
|
|
-}
|
|
|
|
type Parser = Parsec Void String
|
|
|
|
parseDateExpr :: Parser DateExpr
|
|
parseDateExpr = boolExpr
|
|
|
|
-- Lexeme parser functions
|
|
sc :: Parser ()
|
|
sc = L.space space1 (L.skipLineComment "//") (L.skipBlockCommentNested "/*" "*/")
|
|
|
|
symbol :: String -> Parser String
|
|
symbol = L.symbol sc
|
|
|
|
lexeme :: Parser a -> Parser a
|
|
lexeme = L.lexeme sc
|
|
|
|
parens :: Parser a -> Parser a
|
|
parens = between (symbol "(") (symbol ")")
|
|
|
|
integer :: Parser Integer
|
|
integer = lexeme L.decimal
|
|
|
|
bool :: Parser Bool
|
|
bool = (True <$ symbol "true") <|> (False <$ symbol "false")
|
|
|
|
-- Helper functions for creating tables
|
|
prefix name f = Prefix (f <$ symbol name)
|
|
infixL name f = InfixL (f <$ symbol name)
|
|
|
|
-- Parse IntExpr
|
|
intExpr :: Parser IntExpr
|
|
intExpr = makeExprParser intTerm intTable
|
|
|
|
intTable :: [[Operator Parser IntExpr]]
|
|
intTable = [ [prefix "+" id, prefix "-" INeg]
|
|
, [infixL "*" IMul, infixL "/" IDiv, infixL "%" IMod]
|
|
, [infixL "+" IAdd, infixL "-" (IAdd . INeg)]
|
|
]
|
|
|
|
intTerm :: Parser IntExpr
|
|
intTerm = parens intExpr
|
|
<|> IValue <$> integer
|
|
<|> IDate <$> pSpecialDate
|
|
<?> "integer expression"
|
|
|
|
-- Parse BoolExpr
|
|
boolExpr :: Parser BoolExpr
|
|
boolExpr = makeExprParser boolTerm boolTable
|
|
|
|
boolTable :: [[Operator Parser BoolExpr]]
|
|
boolTable = [ [prefix "!" BNot]
|
|
, [infixL "&&" BAnd, infixL "||" BOr]
|
|
]
|
|
|
|
boolTerm :: Parser BoolExpr
|
|
boolTerm = parens boolExpr
|
|
<|> BValue <$> bool
|
|
<|> BStatement <$> pDateStatement
|
|
<|> relExpr
|
|
<?> "boolean expression"
|
|
|
|
relExpr :: Parser BoolExpr
|
|
relExpr = do
|
|
a <- intExpr
|
|
b <- relation
|
|
c <- intExpr
|
|
return $ b a c
|
|
|
|
relation :: Parser (IntExpr -> IntExpr -> BoolExpr)
|
|
relation = (BEq <$ symbol "==")
|
|
<|> ((\a b -> BNot (BEq a b)) <$ symbol "!=")
|
|
<|> ((\a b -> BNot (BLt a b)) <$ symbol ">=")
|
|
<|> ((\a b -> BNot (BGt a b)) <$ symbol "<=")
|
|
<|> (BGt <$ symbol ">")
|
|
<|> (BLt <$ symbol "<")
|
|
<?> "comparison"
|
|
|
|
-- Parse SpecialDates and DateStatements
|
|
pSpecialDate :: Parser SpecialDate
|
|
pSpecialDate = (SJulianDay <$ symbol "julian")
|
|
<|> (SYearCount <$ symbol "yearcount")
|
|
<|> (SDayOfYear <$ symbol "yearday")
|
|
<|> (SYear <$ symbol "year")
|
|
<|> (SMonthCount <$ symbol "monthcount")
|
|
<|> (SMonth <$ symbol "month")
|
|
<|> (SDay <$ symbol "day")
|
|
<|> (SDayOfWeek <$ symbol "weekday")
|
|
<|> (SEaster <$ symbol "easter")
|
|
<?> "special date"
|
|
|
|
pDateStatement :: Parser DateStatement
|
|
pDateStatement = (IsWeekend <$ symbol "isweekend")
|
|
<|> (IsLeapYear <$ symbol "isleapyear")
|
|
<?> "date statement"
|