Parse expressions

Switched to Megaparsec from Parsec.
Also switched eval[...] functions to return Maybe when things like
division by zero would otherwise happen. Wouldn't want any runtime
crashes :P

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?