diff --git a/DateExpr.hs b/DateExpr.hs index 87a6689..d8ffe29 100644 --- a/DateExpr.hs +++ b/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 diff --git a/Task.hs b/Task.hs index 63301d1..46a2e11 100644 --- a/Task.hs +++ b/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 Duration = Int +type Amount = Integer +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