Parse tasks

DateExpr.hs

@@ -3,6 +3,8 @@ module DateExpr
   , parseDateExpr
   , firstMatchingDay
   , evalDateExpr
+  , daily
+  , weekly
   ) where
 
 import Control.Applicative
@@ -23,7 +25,6 @@ type DateExpr = BoolExpr
 
 data BoolExpr = BValue Bool
               | BStatement DateStatement
-              | BLeapYear
               | BNot BoolExpr
               | BAnd BoolExpr BoolExpr
               | BOr BoolExpr BoolExpr
@@ -55,6 +56,12 @@ data SpecialDate = SJulianDay
                  | SEaster
   deriving (Show)
 
+daily :: DateExpr
+daily = BValue True
+
+weekly :: DateExpr
+weekly = BEq (IDate SDayOfWeek) (IValue 7)
+
 {-
  - Evaluating expressions
  -}
@@ -136,7 +143,6 @@ yearday day = let (y,m,d)   = toGregorian day
  - Parsing Expressions
  -}
 
---               error ↓   ↓ input
 type Parser = Parsec Void String
 
 parseDateExpr :: Parser DateExpr
@@ -144,7 +150,7 @@ parseDateExpr = boolExpr
 
 -- Lexeme parser functions
 sc :: Parser ()
-sc = L.space space1 empty empty
+sc = L.space space1 (L.skipLineComment "//") (L.skipBlockCommentNested "/*" "*/")
 
 symbol :: String -> Parser String
 symbol = L.symbol sc

Task.hs

@@ -1,7 +1,13 @@
 module Task where
 
+import DateExpr
+import Control.Applicative
+import Control.Monad
 import Data.Time.Calendar
-import DateExpressions
+import Data.Void
+import Text.Megaparsec
+import Text.Megaparsec.Char
+import qualified Text.Megaparsec.Char.Lexer as L
 
 data Priority = Must
               | Should
@@ -9,12 +15,96 @@ data Priority = Must
   deriving (Eq, Ord, Enum, Show)
 
 type Description = String
-type Amount = Int
+type Amount = Integer
-type Duration = Int
+type Duration = Integer
 
 data When = Forever
           | Until Day
           | During Duration Day
-          | While Duration BoolExpr
+          | Whenever Duration DateExpr
+  deriving (Show)
 
 data Task = Task Priority Description Amount When
+  deriving (Show)
+
+{-
+ - Parse Tasks
+ -}
+
+type Parser = Parsec Void String
+
+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
+
+integer :: (Integral i) => Parser i
+integer = lexeme L.decimal
+
+options :: (a -> Parser a) -> [a] -> Parser a
+options f = foldr1 (<|>) . map f
+
+pDateIso :: Parser Day
+pDateIso = do
+  y <- integer
+  char '-'
+  m <- integer
+  char '-'
+  d <- integer
+  return $ fromGregorian y m d
+
+pDateDots :: Parser Day
+pDateDots = do
+  d <- integer
+  char '.'
+  m <- integer
+  char '.'
+  y <- integer
+  return $ fromGregorian y m d
+
+pDate :: Parser Day
+pDate = try pDateIso <|> pDateDots
+
+pDuration :: Parser Duration
+pDuration = do
+  symbol "for"
+  n <- integer
+  symbol "days" <|> symbol "day"
+  return n
+
+pUntil = symbol "until" *> pDate
+pWhenever = symbol "whenever" *> parseDateExpr
+
+pWhenShortcut :: Parser When
+pWhenShortcut =   Whenever 1 daily  <$ symbol "daily"
+              <|> Whenever 7 weekly <$ symbol "weekly"
+
+pWhen :: Parser When
+pWhen = pWhenShortcut
+      <|> liftA Until pUntil
+      <|> try (liftA2 During pDuration pUntil)
+      <|> liftA2 Whenever pDuration pWhenever
+      <|> return Forever
+
+pPriority :: Parser Priority
+pPriority =   Must   <$ symbol "must"
+          <|> Should <$ symbol "should"
+          <|> Can    <$ options symbol ["can", "might", "may"]
+
+pAmount :: Parser Amount
+pAmount =   1 <$ symbol "once"
+        <|> 2 <$ symbol "twice"
+        <|> integer <* (symbol "times" <|> symbol "time")
+
+pDesc :: Parser Description
+pDesc = between (symbol "<") (symbol ">")
+      $ takeWhile1P (Just "description") (not . (`elem` "<>"))
+
+parseTask :: Parser Task
+-- because liftA only goes up to liftA3
+parseTask =   try (liftM4 Task pPriority pDesc pAmount pWhen)
+          <|> liftM4 Task pPriority pDesc (return 1) pWhen