Create stack project
This commit is contained in:
Joscha
parent
f913392a0a
commit
14c5a29aa4
12 changed files with 167 additions and 0 deletions
238
old/DateExpr.hs
Normal file
238
old/DateExpr.hs
Normal file
|
|
@ -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"
|
||||
119
old/Task.hs
Normal file
119
old/Task.hs
Normal file
|
|
@ -0,0 +1,119 @@
|
|||
module Task where
|
||||
|
||||
import DateExpr
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
import Data.Time.Calendar
|
||||
import Data.Void
|
||||
import Text.Megaparsec
|
||||
import Text.Megaparsec.Char
|
||||
import qualified Text.Megaparsec.Char.Lexer as L
|
||||
|
||||
data Priority = Must
|
||||
| Should
|
||||
| Can
|
||||
deriving (Eq, Ord, Enum, Show)
|
||||
|
||||
type Description = String
|
||||
type Amount = Integer
|
||||
type Duration = Integer
|
||||
|
||||
data When = Forever
|
||||
| Until Day
|
||||
| During Duration Day
|
||||
| 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 = choice . 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"
|
||||
<?> "when"
|
||||
|
||||
pWhen :: Parser When
|
||||
pWhen = pWhenShortcut
|
||||
<|> liftA Until pUntil
|
||||
<|> try (liftA2 During pDuration pUntil)
|
||||
<|> try (liftA2 Whenever pDuration pWhenever)
|
||||
<|> liftA2 Whenever (return 1) pWhenever
|
||||
-- <|> return Forever
|
||||
<?> "when"
|
||||
|
||||
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")
|
||||
<?> "amount"
|
||||
|
||||
pDesc :: Parser Description
|
||||
-- pDesc = between (symbol "<") (symbol ">")
|
||||
-- $ takeWhile1P (Just "description") (not . (`elem` "<>"))
|
||||
pDesc = someTill anyChar (try $ lookAhead pAmountOrWhen) <* sc
|
||||
where pAmountOrWhen = try (sc <* pAmount)
|
||||
<|> sc <* pWhen
|
||||
|
||||
parseTask :: Parser Task
|
||||
-- because liftA only goes up to liftA3
|
||||
parseTask = try (liftM4 Task pPriority pDesc pAmount pWhen)
|
||||
<|> try (liftM4 Task pPriority pDesc (return 1) pWhen)
|
||||
<|> try (liftM4 Task pPriority pDesc pAmount (return Forever))
|
||||
<|> liftM4 Task pPriority (some anyChar) (return 1) (return Forever)
|
||||
Loading…
Add table
Add a link
Reference in a new issue