diff --git a/DateExpr.hs b/DateExpr.hs index e138dea..59752f1 100644 --- a/DateExpr.hs +++ b/DateExpr.hs @@ -1,16 +1,25 @@ module DateExpr - ( BoolExpr - , parseBoolExpr + ( DateExpr + , parseDateExpr , firstMatchingDay - , evalBoolExpr + , evalDateExpr ) 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 Text.Parsec +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 @@ -21,6 +30,7 @@ data BoolExpr = BValue Bool | BEq IntExpr IntExpr | BGt IntExpr IntExpr | BLt IntExpr IntExpr + deriving (Show) data IntExpr = IValue Integer | IDate SpecialDate @@ -29,9 +39,12 @@ data IntExpr = IValue Integer | 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 @@ -40,32 +53,45 @@ data SpecialDate = SJulianDay | SYearCount | SMonthCount | SEaster + deriving (Show) {- - Evaluating expressions -} -firstMatchingDay :: BoolExpr -> Int -> Day -> Maybe Day -firstMatchingDay expr duration = find (evalBoolExpr expr) . take duration . iterate (addDays 1) +evalDateExpr :: DateExpr -> Day -> Bool +evalDateExpr expr = fromMaybe False . evalBoolExpr expr -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 +firstMatchingDay :: DateExpr -> Int -> Day -> Maybe Day +firstMatchingDay expr duration = find (evalDateExpr expr) + . take duration . iterate (addDays 1) -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 +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 @@ -107,8 +133,94 @@ yearday day = let (y,m,d) = toGregorian day in toInteger dayofyear {- - - Parsing BoolExpr + - Parsing DateExpr -} -parseBoolExpr :: String -> Either ParseError BoolExpr -parseBoolExpr = undefined +-- error ↓ ↓ input +type Parser = Parsec Void String + +parseDateExpr :: Parser DateExpr +parseDateExpr = boolExpr + +sc :: Parser () -- oddly necessary +sc = L.space space1 empty empty + +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" + -- comparison (==, <, >, <=, >=) + +relExpr = do + a <- intExpr + b <- relation + c <- intExpr + return $ b a c + +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 "<") + +pSpecialDate = (SJulianDay <$ symbol "julian") + <|> (SDayOfYear <$ symbol "yearday") + <|> (SYearCount <$ symbol "yearcount") + <|> (SYear <$ symbol "year") + <|> (SMonthCount <$ symbol "monthcount") + <|> (SMonth <$ symbol "month") + <|> (SDay <$ symbol "day") + <|> (SDayOfWeek <$ symbol "weekday") + <|> (SEaster <$ symbol "easter") + "special date" -- necessary? + +pDateStatement = (IsWeekend <$ symbol "isweekend") + <|> (IsLeapYear <$ symbol "isleapyear") + "date statement" -- necessary?