Create stack project

old/DateExpr.hs

@@ -0,0 +1,238 @@
+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"