Combine todo.txt related stuff, remove old stuff
This commit is contained in:
Joscha
parent
eaab256cca
commit
8f1b2856dc
18 changed files with 384 additions and 1384 deletions
245
app/Main.hs
245
app/Main.hs
|
|
@ -1,247 +1,10 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception
|
||||
import Control.Monad
|
||||
import Data.List
|
||||
--import Data.Maybe
|
||||
import System.Exit
|
||||
import System.IO.Error
|
||||
|
||||
import qualified Brick.Themes as B
|
||||
import qualified Data.ConfigFile as C
|
||||
--import qualified Data.Text as T
|
||||
--import Data.Time.Calendar
|
||||
--import Data.Time.Clock
|
||||
import qualified Database.SQLite.Simple as DB
|
||||
import qualified Options.Applicative as O
|
||||
import qualified System.Posix.User as P
|
||||
import qualified Brick as B
|
||||
|
||||
import qualified TaskMachine.Config as TM
|
||||
--import qualified TaskMachine.Database as TM
|
||||
--import qualified TaskMachine.DateExpr as TM
|
||||
import qualified TaskMachine.UI as TM
|
||||
import TaskMachine.UI
|
||||
|
||||
-- TODO: When adding oConfigFile back, make oTaskDB a Maybe FilePath.
|
||||
-- This way, it won't always overwrite the task db set in the config.
|
||||
-- TODO: Add a [-c|--export-default-config CONFIGFILE] option
|
||||
-- TODO: Add a [--initialize] flag to create a ~/.taskmachine/ folder and fill it with a default config and theme.
|
||||
-- TODO: Have a look at other programs to see how they deal with this issue.
|
||||
data Options = Options
|
||||
{ oConfigFile :: [FilePath]
|
||||
, oTaskDB :: Maybe FilePath
|
||||
, oThemePaths :: [FilePath]
|
||||
, oExportDefaultConfig :: [FilePath]
|
||||
, oExportDefaultTheme :: [FilePath]
|
||||
} deriving (Show)
|
||||
|
||||
{-
|
||||
- Exit codes
|
||||
-}
|
||||
|
||||
noConfigFile :: ExitCode
|
||||
noConfigFile = ExitFailure 10
|
||||
|
||||
{-
|
||||
- Useful functions
|
||||
-}
|
||||
|
||||
-- Log an action (prefixes "-> ")
|
||||
act :: String -> IO ()
|
||||
act = putStrLn . ("-> " ++)
|
||||
|
||||
{-
|
||||
- Command line options
|
||||
-}
|
||||
|
||||
argParser :: FilePath -> O.Parser Options
|
||||
argParser homedir = pure Options
|
||||
<*> ((++ TM.defaultConfigFilePaths homedir) <$> many configFile)
|
||||
<*> optional taskDB
|
||||
<*> many themePaths
|
||||
<*> many exportDefaultConfig
|
||||
<*> many exportDefaultTheme
|
||||
where
|
||||
configFile = O.strOption $ mconcat
|
||||
[ O.short 'c'
|
||||
, O.long "config"
|
||||
, O.help $ "Where to look for a config file.\
|
||||
\ This option can be set multiple times.\
|
||||
\ If not specified, will look in these locations:\n"
|
||||
++ intercalate "," (map show $ TM.defaultConfigFilePaths homedir)
|
||||
, O.metavar "CONFIGFILE"
|
||||
]
|
||||
taskDB = O.strOption $ mconcat
|
||||
[ O.short 'd'
|
||||
, O.long "task-db"
|
||||
, O.help "Specify the database file where the tasks are saved.\
|
||||
\ This option overwrites the config file."
|
||||
, O.metavar "TASKDB"
|
||||
]
|
||||
themePaths = O.strOption $ mconcat
|
||||
[ O.short 't'
|
||||
, O.long "theme"
|
||||
, O.help "Specify one or more theme files to load.\
|
||||
\ This option can be set zero or more times.\
|
||||
\ This option overwrites the config file."
|
||||
, O.metavar "THEMEFILE"
|
||||
]
|
||||
exportDefaultConfig = O.strOption $ mconcat
|
||||
[ O.short 'C'
|
||||
, O.long "export-default-config"
|
||||
, O.help "Export the application's default config to a file."
|
||||
, O.metavar "CONFIGFILE"
|
||||
]
|
||||
exportDefaultTheme = O.strOption $ mconcat
|
||||
[ O.short 'T'
|
||||
, O.long "export-default-theme"
|
||||
, O.help "Export the application's default theme to a file.\
|
||||
\ This can be used as a starting point for a custom theme."
|
||||
, O.metavar "THEMEFILE"
|
||||
]
|
||||
|
||||
argParserInfo :: FilePath -> O.ParserInfo Options
|
||||
argParserInfo homedir = O.info (O.helper <*> argParser homedir) $ mconcat
|
||||
[ O.fullDesc
|
||||
]
|
||||
|
||||
{-
|
||||
- Loading config and stuff
|
||||
-}
|
||||
|
||||
-- Kinda ugly...
|
||||
loadConfigs :: TM.HomeDir -> [FilePath] -> IO (Maybe TM.Config)
|
||||
loadConfigs _ [] = return Nothing
|
||||
loadConfigs homedir (path:paths) = do
|
||||
act $ "Loading config from " ++ show path ++ "."
|
||||
mConf <- handleOpenFileExceptions $ tryLoadConfig path
|
||||
case mConf of
|
||||
Just conf -> return (Just conf)
|
||||
Nothing -> do
|
||||
putStrLn $ "Could not load config from " ++ show path ++ "."
|
||||
loadConfigs homedir paths
|
||||
where
|
||||
tryLoadConfig :: FilePath -> IO (Maybe TM.Config)
|
||||
tryLoadConfig p = do
|
||||
eConf <- TM.loadConfig homedir p
|
||||
case eConf of
|
||||
Right conf -> return $ Just conf
|
||||
Left (C.ParseError msg) -> Nothing <$ putStrLn msg
|
||||
Left _ -> return Nothing
|
||||
handleOpenFileExceptions :: IO (Maybe a) -> IO (Maybe a)
|
||||
handleOpenFileExceptions f = do
|
||||
res <- tryJust (guard . isRelevantError) f
|
||||
case res of
|
||||
Right m -> return m
|
||||
Left _ -> return Nothing
|
||||
isRelevantError :: IOError -> Bool
|
||||
isRelevantError e = isAlreadyInUseError e
|
||||
|| isDoesNotExistError e
|
||||
|| isPermissionError e
|
||||
|
||||
mergeWithOptions :: TM.Config -> Options -> TM.Config
|
||||
mergeWithOptions = mergeThemePaths <=< mergeTaskDB
|
||||
where
|
||||
mergeThemePaths conf opt = case oThemePaths opt of
|
||||
[] -> conf
|
||||
themes -> conf { TM.cThemes = themes }
|
||||
mergeTaskDB conf opt = case oTaskDB opt of
|
||||
Nothing -> conf
|
||||
Just taskdb -> conf { TM.cTaskDB = taskdb }
|
||||
|
||||
-- Could probably implement using EitherT, but too lazy :)
|
||||
loadThemes :: B.Theme -> [FilePath] -> IO B.Theme
|
||||
loadThemes theme [] = return theme
|
||||
loadThemes theme (path:paths) = do
|
||||
act $ "Loading theme from " ++ show path ++ "."
|
||||
mNewTheme <- handleOpenFileExceptions $ B.loadCustomizations path theme
|
||||
case mNewTheme of
|
||||
Nothing -> do
|
||||
putStrLn $ "Could not load theme from " ++ show path ++ "."
|
||||
loadThemes theme paths
|
||||
Just (Right newTheme) -> loadThemes newTheme paths
|
||||
Just (Left errMsg) -> do
|
||||
putStrLn $ "Could not load theme from " ++ show path ++ ": " ++ errMsg
|
||||
loadThemes theme paths
|
||||
where
|
||||
handleOpenFileExceptions :: IO a -> IO (Maybe a)
|
||||
handleOpenFileExceptions f = do
|
||||
res <- tryJust (guard . isRelevantError) f
|
||||
case res of
|
||||
Right m -> return $ Just m
|
||||
Left _ -> return Nothing
|
||||
isRelevantError :: IOError -> Bool
|
||||
isRelevantError e = isAlreadyInUseError e
|
||||
|| isDoesNotExistError e
|
||||
|| isPermissionError e
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
homedir <- P.homeDirectory <$> (P.getUserEntryForID =<< P.getRealUserID)
|
||||
options <- O.execParser $ argParserInfo homedir
|
||||
|
||||
-- Export default config
|
||||
forM_ (oExportDefaultConfig options) $ \path -> do
|
||||
act $ "Exporting default config to " ++ show path ++ "."
|
||||
TM.saveConfig path $ TM.defaultConfig homedir
|
||||
|
||||
-- Export default theme
|
||||
forM_ (oExportDefaultTheme options) $ \path -> do
|
||||
act $ "Exporting default theme to " ++ show path ++ "."
|
||||
B.saveTheme path TM.defaultTheme
|
||||
|
||||
-- Load config
|
||||
mConfig <- loadConfigs homedir $ oConfigFile options
|
||||
config <- case mConfig of
|
||||
Nothing -> do
|
||||
putStrLn ""
|
||||
putStrLn "Could not find any config file."
|
||||
putStrLn "Use the -C CONFIGFILE flag to generate a default config file."
|
||||
exitWith noConfigFile
|
||||
Just unmergedConfig -> return $ mergeWithOptions unmergedConfig options
|
||||
|
||||
-- According to config, load themes
|
||||
theme <- loadThemes TM.defaultTheme $ TM.cThemes config
|
||||
|
||||
-- ... and initialize db
|
||||
act $ "Using db at " ++ show (TM.cTaskDB config) ++ "."
|
||||
DB.withConnection (TM.cTaskDB config) $ \c -> do
|
||||
--TM.initializeNewDB c
|
||||
|
||||
-- TESTING
|
||||
testDB c
|
||||
|
||||
-- Start the UI
|
||||
error "Implement UI" theme config
|
||||
|
||||
testDB :: DB.Connection -> IO ()
|
||||
testDB _ = do
|
||||
{-
|
||||
now <- utctDay <$> getCurrentTime
|
||||
let deadlineBefore = Just $ addDays (-2) now
|
||||
deadlineAfter = Just $ addDays 2 now
|
||||
boolFormulaText = "weekday == tue && monthcount == 1"
|
||||
boolFormulaExpr = fromJust $ TM.parseBoolExpr boolFormulaText
|
||||
boolFormula = Just $ TM.BoolFormula (T.pack boolFormulaText) boolFormulaExpr
|
||||
duration = 10
|
||||
taskOne = TM.TaskRow 0 deadlineBefore duration Nothing Nothing "task 1" "" 1 0
|
||||
taskTwo = TM.TaskRow 0 deadlineAfter duration Nothing Nothing "task 2" "" 1 0
|
||||
taskThree = TM.TaskRow 0 deadlineBefore duration boolFormula Nothing "task 3" "" 1 1
|
||||
taskFour = TM.TaskRow 0 deadlineAfter duration boolFormula Nothing "task 4" "" 0 0
|
||||
taskFive = TM.TaskRow 0 Nothing duration boolFormula Nothing "task 5" "" 1 0
|
||||
mapM_ (TM.addTask c) [taskOne, taskTwo, taskThree, taskFour, taskFive]
|
||||
TM.updateTasks c now
|
||||
putStrLn "RELEVANT TASKS"
|
||||
tasks <- TM.selectRelevantTasks c now
|
||||
forM_ tasks $ print . TM.rowDescription
|
||||
putStrLn "DOIN A TASK"
|
||||
TM.doTask c $ TM.rowID $ head tasks
|
||||
putStrLn "DELETIN A TASK"
|
||||
TM.removeTask c $ TM.rowID $ tasks !! 1
|
||||
putStrLn "RELEVANT TASKS"
|
||||
tasks2 <- TM.selectRelevantTasks c now
|
||||
forM_ tasks2 $ print . TM.rowDescription
|
||||
-}
|
||||
putStrLn "Everything works (because there's nothing here...)"
|
||||
main :: IO()
|
||||
main = void $ B.defaultMain myApp startState
|
||||
|
|
|
|||
11
package.yaml
11
package.yaml
|
|
@ -22,18 +22,19 @@ description: Please see the README on Github at <https://github.com/Garm
|
|||
dependencies:
|
||||
- base >= 4.7 && < 5
|
||||
- brick
|
||||
- ConfigFile
|
||||
- containers
|
||||
- megaparsec
|
||||
- optparse-applicative
|
||||
- sqlite-simple
|
||||
- text
|
||||
- time
|
||||
- unix
|
||||
- vector
|
||||
- vty
|
||||
# tests
|
||||
- hspec
|
||||
- QuickCheck
|
||||
#- ConfigFile
|
||||
#- optparse-applicative
|
||||
#- sqlite-simple
|
||||
#- text
|
||||
#- unix
|
||||
#- unordered-containers
|
||||
#- transformers
|
||||
#- async
|
||||
|
|
|
|||
|
|
@ -1,56 +0,0 @@
|
|||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module TaskMachine.Config
|
||||
( HomeDir
|
||||
, Config(..)
|
||||
, defaultConfig
|
||||
, defaultConfigFilePaths
|
||||
, loadConfig
|
||||
, saveConfig
|
||||
) where
|
||||
|
||||
import Data.Either
|
||||
|
||||
import qualified Data.ConfigFile as C
|
||||
|
||||
type HomeDir = FilePath
|
||||
|
||||
data Config = Config
|
||||
{ cThemes :: [FilePath]
|
||||
, cTaskDB :: FilePath
|
||||
}
|
||||
|
||||
defaultConfig :: HomeDir -> Config
|
||||
defaultConfig homedir = Config
|
||||
{ cThemes = []
|
||||
, cTaskDB = homedir ++ "/.taskmachine/tasks.db"
|
||||
}
|
||||
|
||||
defaultConfigFilePaths :: HomeDir -> [FilePath]
|
||||
defaultConfigFilePaths homedir =
|
||||
[homedir ++ "/.taskmachine/tasks.conf", "tasks.conf"]
|
||||
|
||||
loadConfig :: HomeDir -> FilePath -> IO (Either C.CPErrorData Config)
|
||||
loadConfig homedir path = do
|
||||
ecp <- C.readfile C.emptyCP path
|
||||
case ecp of
|
||||
Left (e, _) -> return $ Left e
|
||||
Right cp ->
|
||||
let config = defaultConfig homedir
|
||||
myThemes = fromRight (cThemes config) $ C.get cp "DEFAULT" "themes"
|
||||
myTaskDB = fromRight (cTaskDB config) $ C.get cp "DEFAULT" "taskdb"
|
||||
in return $ Right Config
|
||||
{ cThemes = myThemes
|
||||
, cTaskDB = myTaskDB
|
||||
}
|
||||
|
||||
configToParser :: Config -> C.ConfigParser
|
||||
configToParser Config{..} = fromEither $ do
|
||||
cp1 <- C.set C.emptyCP "DEFAULT" "themes" (show cThemes)
|
||||
C.set cp1 "DEFAULT" "taskdb" cTaskDB
|
||||
where
|
||||
fromEither (Left _) = undefined -- This should not be able to fail.
|
||||
fromEither (Right v) = v
|
||||
|
||||
saveConfig :: FilePath -> Config -> IO ()
|
||||
saveConfig path = writeFile path . C.to_string . configToParser
|
||||
|
|
@ -1,235 +0,0 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module TaskMachine.Database where
|
||||
{-
|
||||
( TaskRow(..)
|
||||
, IntFormula(..)
|
||||
, BoolFormula(..)
|
||||
, TaskID
|
||||
, Duration
|
||||
, initializeNewDB
|
||||
, updateTasks
|
||||
, selectRelevantTasks
|
||||
, addTask
|
||||
, editTask
|
||||
, removeTask
|
||||
, doTask
|
||||
) where
|
||||
|
||||
import Control.Exception
|
||||
import Control.Monad
|
||||
import Data.Maybe
|
||||
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Calendar
|
||||
import qualified Database.SQLite.Simple as DB
|
||||
import qualified Database.SQLite.Simple.FromField as DB
|
||||
import qualified Database.SQLite.Simple.Ok as DB
|
||||
import qualified Database.SQLite.Simple.ToField as DB
|
||||
|
||||
import qualified TaskMachine.DateExpr as TM
|
||||
|
||||
data IntFormula = IntFormula
|
||||
{ intFormulaText :: T.Text
|
||||
, intFormulaExpr :: TM.IntExpr
|
||||
}
|
||||
|
||||
instance DB.ToField IntFormula where
|
||||
toField = DB.toField . intFormulaText
|
||||
|
||||
instance DB.FromField IntFormula where
|
||||
fromField f = case DB.fromField f of
|
||||
DB.Errors e -> DB.Errors e
|
||||
DB.Ok text -> case TM.parseIntExpr (T.unpack text) of
|
||||
Nothing -> DB.Errors [] -- TODO: Proper exception?
|
||||
Just expr -> DB.Ok IntFormula{ intFormulaText = text, intFormulaExpr = expr }
|
||||
|
||||
data BoolFormula = BoolFormula
|
||||
{ boolFormulaText :: T.Text
|
||||
, boolFormulaExpr :: TM.BoolExpr
|
||||
}
|
||||
|
||||
instance DB.ToField BoolFormula where
|
||||
toField = DB.toField . boolFormulaText
|
||||
|
||||
instance DB.FromField BoolFormula where
|
||||
fromField f = case DB.fromField f of
|
||||
DB.Errors e -> DB.Errors e
|
||||
DB.Ok text -> case TM.parseBoolExpr (T.unpack text) of
|
||||
Nothing -> DB.Errors [] -- TODO: Proper exception?
|
||||
Just expr -> DB.Ok BoolFormula{ boolFormulaText = text, boolFormulaExpr = expr }
|
||||
|
||||
type TaskID = Integer
|
||||
type Duration = Integer
|
||||
|
||||
data TaskRow = TaskRow
|
||||
{ rowID :: TaskID
|
||||
, rowDeadline :: Maybe Day
|
||||
, rowDuration :: Maybe Integer -- If there is no deadline, duration is irrelevant
|
||||
, rowBoolFormula :: Maybe BoolFormula -- Deadline formula
|
||||
, rowIntFormula :: Maybe IntFormula -- Info formula (e. g. age for birthdays)
|
||||
, rowDescription :: T.Text
|
||||
, rowDetails :: T.Text
|
||||
, rowRepetitionsTotal :: Integer
|
||||
, rowRepetitionsDone :: Integer
|
||||
}
|
||||
|
||||
instance DB.ToRow TaskRow where
|
||||
toRow TaskRow{..} = DB.toRow
|
||||
( rowID
|
||||
, rowDeadline
|
||||
, rowDuration
|
||||
, rowBoolFormula
|
||||
, rowIntFormula
|
||||
, rowDescription
|
||||
, rowDetails
|
||||
, rowRepetitionsTotal
|
||||
, rowRepetitionsDone
|
||||
)
|
||||
|
||||
instance DB.FromRow TaskRow where
|
||||
fromRow = do
|
||||
(a,b,c,d,e,f,g,h,i) <- DB.fromRow
|
||||
let rowID = a
|
||||
rowDeadline = b
|
||||
rowDuration = c
|
||||
rowBoolFormula = d
|
||||
rowIntFormula = e
|
||||
rowDescription = f
|
||||
rowDetails = g
|
||||
rowRepetitionsTotal = h
|
||||
rowRepetitionsDone = i
|
||||
return TaskRow{..}
|
||||
|
||||
-- TODO: Maybe put this in separate module and/or make less specific?
|
||||
allowErrorConstraint :: IO () -> IO ()
|
||||
allowErrorConstraint = handleJust isErrorConstraint (const $ return ())
|
||||
where
|
||||
isErrorConstraint DB.SQLError{DB.sqlError=DB.ErrorConstraint} = Just ()
|
||||
isErrorConstraint _ = Nothing
|
||||
|
||||
initializeNewDB :: DB.Connection -> IO ()
|
||||
initializeNewDB c = do
|
||||
DB.execute_ c createTaskTable
|
||||
DB.execute_ c createVersionTable
|
||||
allowErrorConstraint $ DB.execute c fillVersionTable (DB.Only (1 :: Integer))
|
||||
where
|
||||
createTaskTable =
|
||||
"CREATE TABLE IF NOT EXISTS tasks (\
|
||||
\ id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,\
|
||||
\ deadline TEXT,\
|
||||
\ duration INTEGER NOT NULL,\
|
||||
\ boolFormula TEXT,\
|
||||
\ intFormula TEXT,\
|
||||
\ description TEXT NOT NULL,\
|
||||
\ details TEXT NOT NULL DEFAULT \"\",\
|
||||
\ repetitions_total INTEGER NOT NULL DEFAULT 1,\
|
||||
\ repetitions_done INTEGER NOT NULL DEFAULT 0\
|
||||
\)"
|
||||
createVersionTable =
|
||||
"CREATE TABLE IF NOT EXISTS version (\
|
||||
\ version_number INTEGER PRIMARY KEY\
|
||||
\)"
|
||||
fillVersionTable =
|
||||
"INSERT INTO version (version_number) VALUES (?)"
|
||||
|
||||
updateTask :: Day -> TaskRow -> Maybe (Day, Integer)
|
||||
updateTask day t = do
|
||||
expr <- boolFormulaExpr <$> rowBoolFormula t
|
||||
nextDeadline <- TM.findNext expr day (fromIntegral $ rowDuration t)
|
||||
case rowDeadline t of
|
||||
Nothing -> return (nextDeadline, rowID t)
|
||||
Just prevDeadline ->
|
||||
if prevDeadline == nextDeadline
|
||||
then Nothing
|
||||
else return (nextDeadline, rowID t)
|
||||
|
||||
updateTasks :: DB.Connection -> Day -> IO ()
|
||||
updateTasks c day = DB.withTransaction c $ do
|
||||
tasks <- DB.query_ c selectTasksToUpdate
|
||||
let updated = mapMaybe (updateTask day) tasks
|
||||
DB.executeMany c updateTaskRow updated
|
||||
where
|
||||
selectTasksToUpdate =
|
||||
"SELECT id,deadline,duration,boolFormula,intFormula,description,details,repetitions_total,repetitions_done FROM tasks\
|
||||
\ WHERE boolFormula IS NOT NULL"
|
||||
updateTaskRow =
|
||||
"UPDATE tasks\
|
||||
\ SET deadline = ?\
|
||||
\ , repetitions_done = 0\
|
||||
\ WHERE id = ?"
|
||||
|
||||
selectRelevantTasks :: DB.Connection -> Day -> IO [TaskRow]
|
||||
selectRelevantTasks c day = do
|
||||
tasks <- DB.query c queryInterestingTasks (DB.Only day)
|
||||
return $ filter isWithinDuration tasks
|
||||
where
|
||||
queryInterestingTasks =
|
||||
"SELECT id,deadline,duration,boolFormula,intFormula,description,details,repetitions_total,repetitions_done FROM tasks\
|
||||
\ WHERE (repetitions_done < repetitions_total OR repetitions_total = 0)\
|
||||
\ AND (deadline >= ? OR (deadline IS NULL AND boolFormula IS NULL))"
|
||||
isWithinDuration t = isJust $ do
|
||||
deadline <- rowDeadline t
|
||||
let duration = rowDuration t
|
||||
guard $ addDays (-duration) deadline <= day
|
||||
|
||||
addTask :: DB.Connection -> TaskRow -> IO ()
|
||||
addTask c task = DB.execute c insertTask params
|
||||
where
|
||||
insertTask =
|
||||
"INSERT INTO tasks (deadline,duration,boolFormula,intFormula,description,details,repetitions_total,repetitions_done)\
|
||||
\ VALUES (?,?,?,?,?,?,?,?)"
|
||||
params =
|
||||
( rowDeadline task
|
||||
, rowDuration task
|
||||
, rowBoolFormula task
|
||||
, rowIntFormula task
|
||||
, rowDescription task
|
||||
, rowDetails task
|
||||
, rowRepetitionsTotal task
|
||||
, rowRepetitionsDone task
|
||||
)
|
||||
|
||||
editTask :: DB.Connection -> TaskRow -> IO ()
|
||||
editTask c task = DB.execute c editUpdateTask params
|
||||
where
|
||||
editUpdateTask =
|
||||
"UPDATE tasks\
|
||||
\ SET deadline = ?\
|
||||
\ , duration = ?\
|
||||
\ , boolFormula = ?\
|
||||
\ , intFormula = ?\
|
||||
\ , description = ?\
|
||||
\ , details = ?\
|
||||
\ , repetitions_total = ?\
|
||||
\ , repetitions_done = ?\
|
||||
\ WHERE id = ?"
|
||||
params =
|
||||
( rowDeadline task
|
||||
, rowDuration task
|
||||
, rowBoolFormula task
|
||||
, rowIntFormula task
|
||||
, rowDescription task
|
||||
, rowDetails task
|
||||
, rowRepetitionsTotal task
|
||||
, rowRepetitionsDone task
|
||||
, rowID task
|
||||
)
|
||||
|
||||
removeTask :: DB.Connection -> TaskID -> IO ()
|
||||
removeTask c taskID = DB.execute c deleteTask (DB.Only taskID)
|
||||
where
|
||||
deleteTask =
|
||||
"DELETE FROM tasks\
|
||||
\ WHERE id = ?"
|
||||
|
||||
doTask :: DB.Connection -> TaskID -> IO ()
|
||||
doTask c taskID = DB.execute c incrementTotal (DB.Only taskID)
|
||||
where
|
||||
incrementTotal =
|
||||
"UPDATE tasks\
|
||||
\ SET repetitions_done = repetitions_done + 1\
|
||||
\ WHERE id = ?\
|
||||
\ AND repetitions_done < repetitions_total"
|
||||
-}
|
||||
|
|
@ -1,323 +0,0 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- | Parse and evaluate day-based expressions.
|
||||
-- An expression can be evaluated for any given day.
|
||||
--
|
||||
-- Evaluated expressions return 'Nothing' on impossible mathematical
|
||||
-- operations, for example division by 0.
|
||||
--
|
||||
-- For 'BoolExpr's, use the 'evalBoolExpr'' variant to automatically turn
|
||||
-- 'Nothing' into 'False'.
|
||||
|
||||
module TaskMachine.DateExpr
|
||||
(
|
||||
-- * Boolean expressions
|
||||
BoolExpr
|
||||
, parseBoolExpr
|
||||
, evalBoolExpr
|
||||
, evalBoolExpr'
|
||||
, findNext
|
||||
, findWithin
|
||||
-- * Integer expressions
|
||||
, IntExpr
|
||||
, parseIntExpr
|
||||
, evalIntExpr
|
||||
) where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.Void
|
||||
|
||||
import Data.Time.Calendar
|
||||
import Data.Time.Calendar.Easter
|
||||
import Data.Time.Calendar.OrdinalDate
|
||||
import Data.Time.Calendar.WeekDate
|
||||
import Text.Megaparsec
|
||||
import Text.Megaparsec.Char
|
||||
import qualified Text.Megaparsec.Char.Lexer as L
|
||||
import Text.Megaparsec.Expr
|
||||
|
||||
-- | An expression that returns a 'Bool' when evaluated.
|
||||
data BoolExpr
|
||||
= BValue Bool
|
||||
| BStatement DateStatement
|
||||
| BNot BoolExpr
|
||||
| BAnd BoolExpr BoolExpr
|
||||
| BOr BoolExpr BoolExpr
|
||||
| BSame BoolExpr BoolExpr
|
||||
| BEqual IntExpr IntExpr
|
||||
| BGreater IntExpr IntExpr
|
||||
| BLess IntExpr IntExpr
|
||||
deriving (Show)
|
||||
|
||||
data DateStatement
|
||||
= IsLeapYear
|
||||
| IsWeekend
|
||||
| IsEaster -- same as: easter == 0
|
||||
deriving (Show)
|
||||
|
||||
-- | An expression that returns an 'Integer' when evaluated.
|
||||
data IntExpr
|
||||
= IValue Integer
|
||||
| ISDate SpecialDate
|
||||
| INegate IntExpr
|
||||
| IAdd IntExpr IntExpr
|
||||
| ISubtract IntExpr IntExpr -- same as (\a b -> IAdd a (INeg b))
|
||||
| IMultiply IntExpr IntExpr
|
||||
| IDivide IntExpr IntExpr -- div, not quot
|
||||
| IModulo IntExpr IntExpr -- mod, not rem
|
||||
deriving (Show)
|
||||
|
||||
data SpecialDate
|
||||
= SJulianDay
|
||||
| SYear
|
||||
| SMonth
|
||||
| SDay
|
||||
| SDayOfYear
|
||||
| SDayOfWeek
|
||||
| SYearCount -- nth <day of week> of the year
|
||||
| SMonthCount -- nth <day of week> of the month
|
||||
| SEaster
|
||||
deriving (Show)
|
||||
|
||||
-- | Parse a 'BoolExpr' from a string.
|
||||
parseBoolExpr :: String -> Maybe BoolExpr
|
||||
parseBoolExpr = parseMaybe boolExpr
|
||||
|
||||
-- | Parse an 'IntExpr' from a string.
|
||||
parseIntExpr :: String -> Maybe IntExpr
|
||||
parseIntExpr = parseMaybe intExpr
|
||||
|
||||
-- | Find the next day where the expression evaluates to @True@.
|
||||
-- If no day could be found, returns @Nothing@.
|
||||
--
|
||||
-- This function uses 'evalBoolExpr'' to evaluate boolean expressions.
|
||||
findNext :: Day -> Int -> BoolExpr -> Maybe Day
|
||||
findNext start duration expr =
|
||||
let possibleDays = take duration $ iterate (addDays 1) start
|
||||
in find (evalBoolExpr' expr) possibleDays
|
||||
|
||||
-- | Returns a list of days where the expression evaluates to @True@.
|
||||
--
|
||||
-- This function uses 'evalBoolExpr'' to evaluate boolean expressions.
|
||||
findWithin :: Day -> Int -> BoolExpr -> [Day]
|
||||
findWithin start duration expr =
|
||||
let possibleDays = take duration $ iterate (addDays 1) start
|
||||
in filter (evalBoolExpr' expr) possibleDays
|
||||
|
||||
{-
|
||||
- Evaluating expressions
|
||||
-}
|
||||
|
||||
-- | Evaluates a 'BoolExpr' for a given day.
|
||||
--
|
||||
-- Returns @Nothing@ if the expression contains any 'IntExpr'
|
||||
-- that evaluates to @Nothing@ (i. e. contains a mathematical impossibility).
|
||||
evalBoolExpr :: BoolExpr -> Day -> Maybe Bool
|
||||
evalBoolExpr (BValue v) _ = pure v
|
||||
evalBoolExpr (BStatement s) d = pure $ 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 (BSame a b) d = (==) <$> evalBoolExpr a d <*> evalBoolExpr b d
|
||||
evalBoolExpr (BEqual a b) d = (==) <$> evalIntExpr a d <*> evalIntExpr b d
|
||||
evalBoolExpr (BGreater a b) d = (>) <$> evalIntExpr a d <*> evalIntExpr b d
|
||||
evalBoolExpr (BLess a b) d = (<) <$> evalIntExpr a d <*> evalIntExpr b d
|
||||
|
||||
-- | A variant of 'evalBoolExpr' that evaluates to False when the
|
||||
-- result of the evaluation is @Nothing@.
|
||||
--
|
||||
-- @'evalBoolExpr'' expr = 'fromMaybe' 'False' . 'evalBoolExpr' expr@
|
||||
evalBoolExpr' :: BoolExpr -> Day -> Bool
|
||||
evalBoolExpr' expr = fromMaybe False . evalBoolExpr expr
|
||||
|
||||
evalDateStatement :: DateStatement -> Day -> Bool
|
||||
evalDateStatement IsLeapYear d = isLeapYear $ year d
|
||||
evalDateStatement IsWeekend d = weekday d `elem` [6,7]
|
||||
evalDateStatement IsEaster d = orthodoxEaster (year d) == d
|
||||
|
||||
unlessSecondIsZero
|
||||
:: (Integer -> Integer -> Integer)
|
||||
-> IntExpr -> IntExpr -> Day -> Maybe Integer
|
||||
unlessSecondIsZero f a b d = do
|
||||
x <- evalIntExpr a d
|
||||
y <- evalIntExpr b d
|
||||
guard $ y /= 0
|
||||
return $ f x y
|
||||
|
||||
-- | Evaluates an 'IntExpr' for a given day.
|
||||
--
|
||||
-- Returns a @Nothing@ when a division by 0 or modulo 0 occurs.
|
||||
evalIntExpr :: IntExpr -> Day -> Maybe Integer
|
||||
evalIntExpr (IValue v) _ = pure v
|
||||
evalIntExpr (ISDate s) d = pure $ evalSpecialDate s d
|
||||
evalIntExpr (INegate a) d = negate <$> evalIntExpr a d
|
||||
evalIntExpr (IAdd a b) d = (+) <$> evalIntExpr a d <*> evalIntExpr b d
|
||||
evalIntExpr (ISubtract a b) d = (-) <$> evalIntExpr a d <*> evalIntExpr b d
|
||||
evalIntExpr (IMultiply a b) d = (*) <$> evalIntExpr a d <*> evalIntExpr b d
|
||||
evalIntExpr (IDivide a b) d = unlessSecondIsZero div a b d
|
||||
evalIntExpr (IModulo a b) d = unlessSecondIsZero mod a b d
|
||||
|
||||
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 (orthodoxEaster $ year d) d -- days after easter
|
||||
|
||||
{-
|
||||
- Helper functions for evaluation
|
||||
-}
|
||||
|
||||
julian :: Day -> Integer
|
||||
julian = toModifiedJulianDay
|
||||
|
||||
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 d = let (_,r) = toOrdinalDate d in toInteger r
|
||||
|
||||
{-
|
||||
- Parsing
|
||||
-}
|
||||
|
||||
type Parser = Parsec Void String
|
||||
|
||||
sc :: Parser ()
|
||||
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 = (1 <$ (symbol "monday" <|> symbol "mon"))
|
||||
<|> (2 <$ (symbol "tuesday" <|> symbol "tue"))
|
||||
<|> (3 <$ (symbol "wednesday" <|> symbol "wed"))
|
||||
<|> (4 <$ (symbol "thursday" <|> symbol "thu"))
|
||||
<|> (5 <$ (symbol "friday" <|> symbol "fri"))
|
||||
<|> (6 <$ (symbol "saturday" <|> symbol "sat"))
|
||||
<|> (7 <$ (symbol "sunday" <|> symbol "sun"))
|
||||
<|> lexeme L.decimal
|
||||
<?> "integer or day of week"
|
||||
|
||||
bool :: Parser Bool
|
||||
bool = (True <$ symbol "true")
|
||||
<|> (False <$ symbol "false")
|
||||
<?> "boolean value"
|
||||
|
||||
-- Helper functions for defining tables
|
||||
prefix :: String -> (a -> a) -> Operator Parser a
|
||||
prefix name f = Prefix (f <$ symbol name)
|
||||
|
||||
infixL :: String -> (a -> a -> a) -> Operator Parser a
|
||||
infixL name f = InfixL (f <$ symbol name)
|
||||
|
||||
-- Parse IntExpr
|
||||
intExpr :: Parser IntExpr
|
||||
intExpr = makeExprParser intTerm intTable
|
||||
|
||||
intTable :: [[Operator Parser IntExpr]]
|
||||
intTable =
|
||||
[ [ prefix "+" id
|
||||
, prefix "-" INegate
|
||||
]
|
||||
, [ infixL "*" IMultiply
|
||||
, infixL "/" IDivide
|
||||
, infixL "%" IModulo
|
||||
]
|
||||
, [ infixL "+" IAdd
|
||||
, infixL "-" ISubtract
|
||||
]
|
||||
]
|
||||
|
||||
-- WARNING: Leave the ISDate parser before the integer parser, otherwise
|
||||
-- "month" and "monthcount" won't parse because the integer parser parses
|
||||
-- "mon" (monday).
|
||||
intTerm :: Parser IntExpr
|
||||
intTerm = parens intExpr
|
||||
<|> ISDate <$> pSpecialDate
|
||||
<|> IValue <$> integer
|
||||
<?> "integer expression"
|
||||
|
||||
-- Parse BoolExpr
|
||||
boolExpr :: Parser BoolExpr
|
||||
boolExpr = makeExprParser boolTerm boolTable
|
||||
|
||||
boolTable :: [[Operator Parser BoolExpr]]
|
||||
boolTable =
|
||||
[ [ prefix "!" BNot
|
||||
]
|
||||
, [ infixL "&&" BAnd
|
||||
, infixL "||" BOr
|
||||
]
|
||||
, [ infixL "==" BSame
|
||||
, infixL "!=" (\a b -> BNot (BSame a b))
|
||||
]
|
||||
]
|
||||
|
||||
boolTerm :: Parser BoolExpr
|
||||
boolTerm = parens boolExpr
|
||||
<|> BValue <$> bool
|
||||
<|> BStatement <$> pDateStatement
|
||||
<|> relIntExpr
|
||||
<?> "boolean expression"
|
||||
|
||||
relIntExpr :: Parser BoolExpr
|
||||
relIntExpr = do
|
||||
first <- intExpr
|
||||
rel <- intRelation
|
||||
second <- intExpr
|
||||
return $ rel first second
|
||||
|
||||
intRelation :: Parser (IntExpr -> IntExpr -> BoolExpr)
|
||||
intRelation = (BEqual <$ symbol "==")
|
||||
<|> ((\a b -> BNot (BEqual a b)) <$ symbol "!=")
|
||||
<|> ((\a b -> BNot (BLess a b)) <$ symbol ">=")
|
||||
<|> ((\a b -> BNot (BGreater a b)) <$ symbol "<=")
|
||||
<|> (BGreater <$ symbol ">")
|
||||
<|> (BLess <$ symbol "<")
|
||||
<?> "integer comparison"
|
||||
|
||||
-- WARNING: If one name contains another name (e. g. "monthcount" and "month"),
|
||||
-- put the longer name first, or else it will never parse correctly.
|
||||
pSpecialDate :: Parser SpecialDate
|
||||
pSpecialDate = name SJulianDay "julian"
|
||||
<|> name SDay "day"
|
||||
<|> name SYearCount "yearcount"
|
||||
<|> name SDayOfYear "yearday"
|
||||
<|> name SYear "year"
|
||||
<|> name SDayOfWeek "weekday"
|
||||
<|> name SMonthCount "monthcount"
|
||||
<|> name SMonth "month"
|
||||
<|> name SEaster "easter"
|
||||
<?> "special date"
|
||||
where name a b = a <$ symbol b
|
||||
|
||||
pDateStatement :: Parser DateStatement
|
||||
pDateStatement = name IsLeapYear "isleapyear"
|
||||
<|> name IsWeekend "isweekend"
|
||||
<|> name IsEaster "iseaster"
|
||||
<?> "date statement"
|
||||
where name a b = a <$ symbol b
|
||||
|
|
@ -1,83 +0,0 @@
|
|||
-- | Tasks and events can have one or multiple deadlines.
|
||||
--
|
||||
-- This module contains a representation for single deadlines,
|
||||
-- and some useful functions for calculating things with them.
|
||||
|
||||
module TaskMachine.Deadline
|
||||
( Deadline(..)
|
||||
, Duration
|
||||
-- * Calculations
|
||||
, relevant
|
||||
, isRelevant
|
||||
, nextDeadlines
|
||||
, relevant'
|
||||
, isRelevant'
|
||||
, nextDeadlines'
|
||||
) where
|
||||
|
||||
import Data.Maybe
|
||||
|
||||
import Data.Time.Calendar
|
||||
|
||||
import qualified TaskMachine.DateExpr as TM
|
||||
|
||||
-- | Duration of a task or event in days.
|
||||
--
|
||||
-- A duration of 1 means one day.
|
||||
-- Because of this, 'Duration' values __must always be greater than 0__.
|
||||
type Duration = Int
|
||||
|
||||
-- | A way to represent a deadline, either as a fixed date or using a formula.
|
||||
data Deadline
|
||||
= DFixed Day (Maybe Duration)
|
||||
| DExpression TM.BoolExpr Duration
|
||||
|
||||
-- | Find the next date of the 'Deadline' that's important for a certain day.
|
||||
-- This returns a @Just@ when the day lies within the duration specified.
|
||||
--
|
||||
-- If no duration is specified in a 'DFixed' deadline, all days before the deadline,
|
||||
-- including the deadline itself, are important (i. e. the duration is infinite).
|
||||
relevant :: Day -> Deadline -> Maybe Day
|
||||
relevant today (DExpression expr duration) = TM.findNext today duration expr
|
||||
relevant today (DFixed day Nothing)
|
||||
| diffDays day today >= 0 = Just day
|
||||
| otherwise = Nothing
|
||||
relevant today (DFixed day (Just duration))
|
||||
| diff >= 0 && diff < toInteger duration = Just day
|
||||
| otherwise = Nothing
|
||||
where diff = diffDays day today
|
||||
|
||||
-- | A version of 'relevant' modified to take a list of Deadlines.
|
||||
relevant' :: Day -> [Deadline] -> Maybe Day
|
||||
relevant' today deadlines =
|
||||
let relevants = mapMaybe (relevant today) deadlines
|
||||
in case relevants of
|
||||
[] -> Nothing
|
||||
days -> Just $ minimum days
|
||||
|
||||
|
||||
|
||||
-- | Whether the 'Deadline' is relevant on the current day or not.
|
||||
--
|
||||
-- This function works like 'relevant', only that the actual date calculated is irrelevant.
|
||||
--
|
||||
-- @'isRelevant' day = 'isJust' . 'relevant' day@
|
||||
isRelevant :: Day -> Deadline -> Bool
|
||||
isRelevant day = isJust . relevant day -- Hey, this even reads like English! :D
|
||||
|
||||
-- | A version of 'isRelevant' modified to take a list of Deadlines.
|
||||
isRelevant' :: Day -> [Deadline] -> Bool
|
||||
isRelevant' day = any (isRelevant day)
|
||||
|
||||
-- | Calculate all occurrences of this deadline within the duration given.
|
||||
nextDeadlines :: Day -> Duration -> Deadline -> [Day]
|
||||
nextDeadlines start duration (DFixed day _)
|
||||
| diff >= 0 && diff < toInteger duration = [day]
|
||||
| otherwise = []
|
||||
where diff = diffDays day start
|
||||
nextDeadlines start duration (DExpression expr _) =
|
||||
TM.findWithin start duration expr
|
||||
|
||||
-- | A version of 'nextDeadlines' modified to take a list of Deadlines.
|
||||
nextDeadlines' :: Day -> Duration -> [Deadline] -> [Day]
|
||||
nextDeadlines' start duration = concatMap (nextDeadlines start duration)
|
||||
|
|
@ -1,23 +0,0 @@
|
|||
module TaskMachine.Subtask
|
||||
( Subtask(..)
|
||||
, SubtaskID
|
||||
, allRepetitionsTotal
|
||||
, allRepetitionsDone
|
||||
) where
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
type SubtaskID = Integer
|
||||
|
||||
data Subtask = Subtask
|
||||
{ subID :: SubtaskID
|
||||
, subLabel :: T.Text
|
||||
, subRepetitionsTotal :: Integer
|
||||
, subRepetitionsDone :: Integer
|
||||
}
|
||||
|
||||
allRepetitionsTotal :: [Subtask] -> Integer
|
||||
allRepetitionsTotal = sum . map subRepetitionsTotal
|
||||
|
||||
allRepetitionsDone :: [Subtask] -> Integer
|
||||
allRepetitionsDone = sum . map subRepetitionsDone
|
||||
|
|
@ -1,92 +0,0 @@
|
|||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
-- | Task related stuff.
|
||||
--
|
||||
-- This module will be used by both the UI and the database modules.
|
||||
-- It contains some functionality independent of any of those modules.
|
||||
--
|
||||
-- (Although I don't really know what exactly that will be.)
|
||||
|
||||
module TaskMachine.Task
|
||||
( Task(..)
|
||||
, TaskID
|
||||
) where
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
import qualified TaskMachine.DateExpr as TM
|
||||
import qualified TaskMachine.Deadline as TM
|
||||
import qualified TaskMachine.Subtask as TM
|
||||
|
||||
type TaskID = Integer
|
||||
|
||||
data Task = Task
|
||||
{ taskID :: TaskID
|
||||
, taskDeadlines :: [TM.Deadline]
|
||||
, taskFormula :: Maybe TM.IntExpr
|
||||
, taskDescription :: T.Text
|
||||
, taskDetails :: T.Text
|
||||
, taskSubtasks :: [TM.Subtask]
|
||||
}
|
||||
|
||||
data EmptyTask = EmptyTask
|
||||
{ etaskID :: TaskID
|
||||
, etaskFormula :: Maybe TM.IntExpr
|
||||
, etaskDescription :: T.Text
|
||||
, etaskDetails :: T.Text
|
||||
}
|
||||
|
||||
{-
|
||||
( Task(..)
|
||||
, Deadline(..)
|
||||
, fromTaskRow
|
||||
, toTaskRow
|
||||
) where
|
||||
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Calendar
|
||||
|
||||
import qualified TaskMachine.Database as TM
|
||||
|
||||
data Task = Task
|
||||
{ taskID :: TM.TaskID
|
||||
, taskDeadline :: Deadline
|
||||
, taskIntFormula :: Maybe TM.IntFormula
|
||||
, taskDescription :: T.Text
|
||||
, taskDetails :: T.Text
|
||||
, taskRepetitionsTotal :: Integer
|
||||
, taskRepetitionsDone :: Integer
|
||||
}
|
||||
|
||||
data Deadline
|
||||
= DeadlineNone
|
||||
| DeadlineDay Day (Maybe TM.Duration)
|
||||
| DeadlineFormula TM.BoolFormula TM.Duration
|
||||
|
||||
getDeadline :: TM.TaskRow -> Deadline
|
||||
getDeadline row = case TM.rowBoolFormula row of
|
||||
Just formula -> DeadlineFormula formula $ fromMaybe 1 $ TM.rowDuration row
|
||||
Nothing -> case TM.rowDeadline row of
|
||||
Just day -> DeadlineDay day $ TM.rowDuration row
|
||||
Nothing -> DeadlineNone
|
||||
|
||||
fromTaskRow :: TM.TaskRow -> Task
|
||||
fromTaskRow row =
|
||||
let taskID = TM.rowID row
|
||||
taskDeadline = getDeadline row
|
||||
taskIntFormula = TM.rowIntFormula row
|
||||
taskDescription = TM.rowDescription row
|
||||
taskDetails = TM.rowDetails row
|
||||
taskRepetitionsTotal = TM.rowRepetitionsTotal
|
||||
taskRepetitionsDone = TM.rowRepetitionsDone
|
||||
in Task{..}
|
||||
|
||||
toTaskRow :: Task -> TM.TaskRow
|
||||
toTaskRow task = undefined task
|
||||
|
||||
nextDeadline :: Day -> Deadline -> Maybe Day
|
||||
updateDeadline (DeadlineFormula formula duration) =
|
||||
let expr = boolFormulaExpr formula
|
||||
in Just $ TM.findNext expr day duration
|
||||
updateDeadline _ = Nothing
|
||||
-}
|
||||
14
src/TaskMachine/TaskList.hs
Normal file
14
src/TaskMachine/TaskList.hs
Normal file
|
|
@ -0,0 +1,14 @@
|
|||
-- | A way to store the 'Task's that preserves the original task order
|
||||
|
||||
module TaskMachine.TaskList
|
||||
( LTask(..)
|
||||
) where
|
||||
|
||||
import TaskMachine.Todotxt
|
||||
|
||||
data LTask = LTask
|
||||
{ ltaskNumber :: Integer
|
||||
-- ^ Sort by this number to get the original order of the tasks
|
||||
, ltaskTast :: Task
|
||||
-- ^ The 'Task' itself
|
||||
}
|
||||
150
src/TaskMachine/Todotxt.hs
Normal file
150
src/TaskMachine/Todotxt.hs
Normal file
|
|
@ -0,0 +1,150 @@
|
|||
-- | Read, parse and write tasks in the <https://github.com/todotxt/todo.txt todo.txt> format.
|
||||
|
||||
module TaskMachine.Todotxt
|
||||
(
|
||||
-- * Tasks
|
||||
Task(..)
|
||||
, formatTask
|
||||
-- * Creation and deletion dates
|
||||
, Dates(..)
|
||||
, formatDates
|
||||
-- * Task priority
|
||||
, Priority(..)
|
||||
, formatPriority
|
||||
, priorityToChar
|
||||
, charToPriority
|
||||
-- * Parsing
|
||||
, day
|
||||
, dates
|
||||
, priorityChar
|
||||
, priority
|
||||
) where
|
||||
|
||||
import Control.Monad
|
||||
import Data.List.NonEmpty
|
||||
import Data.Void
|
||||
|
||||
import Data.Set as Set
|
||||
import Data.Time.Calendar
|
||||
import Text.Megaparsec
|
||||
import Text.Megaparsec.Char
|
||||
import Text.Megaparsec.Error
|
||||
|
||||
type Parser = Parsec Void String
|
||||
|
||||
{- Dates -}
|
||||
|
||||
data Dates
|
||||
= CrDate Day
|
||||
| CoCrDate Day Day
|
||||
deriving (Eq, Show)
|
||||
|
||||
formatDates :: Dates -> String
|
||||
formatDates (CrDate cr) = show cr
|
||||
formatDates (CoCrDate cr co) = show cr ++ " " ++ show co
|
||||
|
||||
{- Dates parsing -}
|
||||
|
||||
day :: Parser Day
|
||||
day = label "date" $ do
|
||||
y <- integer
|
||||
void $ char '-'
|
||||
m <- int
|
||||
void $ char '-'
|
||||
d <- int
|
||||
pure $ fromGregorian y m d
|
||||
where
|
||||
integer :: Parser Integer
|
||||
integer = read <$> count 4 digitChar
|
||||
int :: Parser Int
|
||||
int = read <$> count 2 digitChar
|
||||
|
||||
dates :: Parser Dates
|
||||
dates = try datesCrCo <|> datesCr
|
||||
where
|
||||
datesCrCo :: Parser Dates
|
||||
datesCrCo = CoCrDate <$> (day <* char ' ') <*> day
|
||||
datesCr :: Parser Dates
|
||||
datesCr = CrDate <$> day
|
||||
|
||||
{- Priority -}
|
||||
|
||||
data Priority
|
||||
= PrioA | PrioB | PrioC | PrioD | PrioE | PrioF | PrioG
|
||||
| PrioH | PrioI | PrioJ | PrioK | PrioL | PrioM | PrioN
|
||||
| PrioO | PrioP | PrioQ | PrioR | PrioS | PrioT | PrioU
|
||||
| PrioV | PrioW | PrioX | PrioY | PrioZ
|
||||
deriving (Bounded, Enum, Eq, Show, Ord)
|
||||
|
||||
priorityToChar :: Priority -> Char
|
||||
priorityToChar p = toEnum (fromEnum 'A' + fromEnum p)
|
||||
|
||||
charToPriority :: Char -> Maybe Priority
|
||||
charToPriority c
|
||||
| min_value <= value && value <= max_value = Just $ toEnum value
|
||||
| otherwise = Nothing
|
||||
where
|
||||
value = fromEnum c - fromEnum 'A'
|
||||
min_value = fromEnum (minBound :: Priority)
|
||||
max_value = fromEnum (maxBound :: Priority)
|
||||
|
||||
formatPriority :: Priority -> String
|
||||
formatPriority p = '(' : priorityToChar p : ")"
|
||||
|
||||
{- Priority parsing -}
|
||||
|
||||
priorityChar :: Parser Priority
|
||||
priorityChar = do
|
||||
c <- anyChar
|
||||
case charToPriority c of
|
||||
Just p -> pure p
|
||||
Nothing -> failure (Just $ Tokens $ c :| [])
|
||||
(Set.singleton $ Label $ 'p' :| "riority character")
|
||||
|
||||
priority :: Parser Priority
|
||||
priority = char '(' *> priorityChar <* char ')'
|
||||
|
||||
{- Task -}
|
||||
|
||||
data Task = Task
|
||||
{ taskCompleted :: Bool
|
||||
, taskPriority :: Maybe Priority
|
||||
, taskDates :: Maybe Dates
|
||||
, taskDescription :: String -- might change in the future
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
--instance Show Task where
|
||||
-- show = formatTask
|
||||
|
||||
formatTask :: Task -> String
|
||||
formatTask (Task done prio dates desc)
|
||||
= (if done then "x " else "")
|
||||
++ maybe "" ((++" ") . formatPriority) prio
|
||||
++ maybe "" ((++" ") . formatDates) dates
|
||||
++ desc
|
||||
|
||||
{- Task parsing -}
|
||||
|
||||
andSpace :: Parser a -> Parser a
|
||||
andSpace p = p <* char ' '
|
||||
|
||||
completed :: Parser ()
|
||||
completed = void $ char 'x'
|
||||
|
||||
boolParse :: Parser a -> Parser Bool
|
||||
boolParse p = (True <$ try p) <|> pure False
|
||||
|
||||
maybeParse :: Parser a -> Parser (Maybe a)
|
||||
maybeParse p = (Just <$> try p) <|> pure Nothing
|
||||
|
||||
untilEndOfLine :: Parser String
|
||||
untilEndOfLine = takeWhile1P (Just "description") (/='\n')
|
||||
|
||||
task :: Parser Task
|
||||
task = do
|
||||
taskCompleted <- boolParse (andSpace completed)
|
||||
taskPriority <- maybeParse (andSpace priority)
|
||||
taskDates <- maybeParse (andSpace dates)
|
||||
taskDescription <- untilEndOfLine
|
||||
pure $ Task taskCompleted taskPriority taskDates taskDescription
|
||||
|
|
@ -1,96 +0,0 @@
|
|||
-- | Read, parse and write files in the <https://github.com/todotxt/todo.txt todo.txt> format.
|
||||
|
||||
module TaskMachine.Todotxt.Dates
|
||||
( Dates()
|
||||
, showDates
|
||||
-- * Modification
|
||||
, creationDate
|
||||
, completionDate
|
||||
, setCreationDate
|
||||
, setCompletionDate
|
||||
-- * Parsing
|
||||
, day
|
||||
, dates
|
||||
) where
|
||||
|
||||
import Control.Monad
|
||||
import Data.Void
|
||||
|
||||
import Data.Time.Calendar
|
||||
import Text.Megaparsec
|
||||
import Text.Megaparsec.Char
|
||||
|
||||
-- | The combination of creation and completion date of a task.
|
||||
--
|
||||
-- These two dates were combined because, according to the
|
||||
-- <https://github.com/todotxt/todo.txt/blob/master/README.md#todotxt-format-rules todo.txt format rules>,
|
||||
-- the creation date "must be specified if completion date is".
|
||||
data Dates
|
||||
= NoDate
|
||||
| CrDate Day
|
||||
| CrCoDate Day Day
|
||||
deriving (Show)
|
||||
|
||||
{- Modification -}
|
||||
|
||||
-- | Convert a 'Dates' to a string representation that can be used inside a todo.txt task
|
||||
-- and parsed by 'dates'
|
||||
showDates :: Dates -> String
|
||||
showDates NoDate = ""
|
||||
showDates (CrDate creation) = show creation
|
||||
showDates (CrCoDate creation completion) = show creation ++ " " ++ show completion
|
||||
|
||||
-- | Retrieve the creation date, if one exists
|
||||
creationDate :: Dates -> Maybe Day
|
||||
creationDate (CrCoDate day _) = Just day
|
||||
creationDate (CrDate day) = Just day
|
||||
creationDate NoDate = Nothing
|
||||
|
||||
-- | Retrieve the completion date, if one exists
|
||||
completionDate :: Dates -> Maybe Day
|
||||
completionDate (CrCoDate _ day) = Just day
|
||||
completionDate _ = Nothing
|
||||
|
||||
-- | Set the creation date to a specific value
|
||||
setCreationDate :: Day -> Dates -> Dates
|
||||
setCreationDate creation (CrCoDate _ completion) = CrCoDate creation completion
|
||||
setCreationDate creation _ = CrDate creation
|
||||
|
||||
-- | Set the completion date to a specific value.
|
||||
--
|
||||
-- The first argument is a default creation date, in case none exists.
|
||||
-- This is because a completion date can only exist in combination with a
|
||||
-- creation date, as per the todo.txt format.
|
||||
setCompletionDate :: Day -> Day -> Dates -> Dates
|
||||
setCompletionDate _ completion (CrCoDate creation _) = CrCoDate creation completion
|
||||
setCompletionDate creation completion _ = CrCoDate creation completion
|
||||
|
||||
{- Parsing -}
|
||||
|
||||
type Parser = Parsec Void String
|
||||
|
||||
-- | Parse one date of the format @YYYY-MM-DD@ (with no leading or trailing spaces).
|
||||
day :: Parser Day
|
||||
day = label "date" $ do
|
||||
y <- integer
|
||||
void $ char '-'
|
||||
m <- int
|
||||
void $ char '-'
|
||||
d <- int
|
||||
pure $ fromGregorian y m d
|
||||
where
|
||||
integer :: Parser Integer
|
||||
integer = read <$> count 4 digitChar
|
||||
int :: Parser Int
|
||||
int = read <$> count 2 digitChar
|
||||
|
||||
-- | Parse either zero, one or two dates of the format @YYYY-MM-DD@ (with no leading or trailing spaces).
|
||||
--
|
||||
-- If only one date is present, it is interpreted as the creation date.
|
||||
dates :: Parser Dates
|
||||
dates = try datesCrCo <|> try datesCr <|> pure NoDate
|
||||
where
|
||||
datesCrCo :: Parser Dates
|
||||
datesCrCo = CrCoDate <$> day <*> (char ' ' *> day)
|
||||
datesCr :: Parser Dates
|
||||
datesCr = CrDate <$> day
|
||||
|
|
@ -1,72 +0,0 @@
|
|||
-- | Read, parse and write files in the <https://github.com/todotxt/todo.txt todo.txt> format.
|
||||
|
||||
module TaskMachine.Todotxt.Priority
|
||||
( Priority()
|
||||
, priorityToChar
|
||||
, charToPriority
|
||||
, showPriority
|
||||
-- * Parsing
|
||||
, priorityChar
|
||||
, priority
|
||||
) where
|
||||
|
||||
import Control.Monad
|
||||
import Data.List.NonEmpty
|
||||
import Data.Void
|
||||
|
||||
import Data.Set as Set
|
||||
import Data.Time.Calendar
|
||||
import Text.Megaparsec
|
||||
import Text.Megaparsec.Char
|
||||
import Text.Megaparsec.Error
|
||||
|
||||
-- | A task's priority.
|
||||
--
|
||||
-- Priorities are labeled using uppercase A to Z,
|
||||
-- with priority A being the most important priority.
|
||||
-- In the 'Priority' type, priority A is the smallest priority.
|
||||
--
|
||||
-- Tasks should be sorted from smallest to largest (i. e. least important) priority.
|
||||
-- Tasks without priority should appear after tasks with priority.
|
||||
data Priority
|
||||
= PrioA | PrioB | PrioC | PrioD | PrioE | PrioF | PrioG
|
||||
| PrioH | PrioI | PrioJ | PrioK | PrioL | PrioM | PrioN
|
||||
| PrioO | PrioP | PrioQ | PrioR | PrioS | PrioT | PrioU
|
||||
| PrioV | PrioW | PrioX | PrioY | PrioZ
|
||||
deriving (Bounded, Enum, Eq, Show, Ord)
|
||||
|
||||
-- | Convert a priority to its corresponding character of the alphabet
|
||||
priorityToChar :: Priority -> Char
|
||||
priorityToChar p = toEnum (fromEnum 'A' + fromEnum p)
|
||||
|
||||
-- | Convert a character of the alphabet (uppercase A to Z)
|
||||
-- to its corresponding priority
|
||||
charToPriority :: Char -> Maybe Priority
|
||||
charToPriority c
|
||||
| min_value <= value && value <= max_value = Just $ toEnum value
|
||||
| otherwise = Nothing
|
||||
where
|
||||
value = fromEnum c - fromEnum 'A'
|
||||
min_value = fromEnum (minBound :: Priority)
|
||||
max_value = fromEnum (maxBound :: Priority)
|
||||
|
||||
-- | Convert a 'Priority' to a string representation that can be used inside a todo.txt task
|
||||
-- and parsed by 'priority'
|
||||
showPriority :: Priority -> String
|
||||
showPriority p = '(' : priorityToChar p : ")"
|
||||
|
||||
{- Parsing -}
|
||||
|
||||
type Parser = Parsec Void String
|
||||
|
||||
-- | Parse a priority character (see 'priorityToChar') and return the corresponding priority
|
||||
priorityChar :: Parser Priority
|
||||
priorityChar = do
|
||||
c <- anyChar
|
||||
case charToPriority c of
|
||||
Just p -> pure p
|
||||
Nothing -> failure (Just $ Tokens $ c :| []) (Set.singleton $ Label $ 'p' :| "riority character")
|
||||
|
||||
-- | Parse a priority of the format @(*)@ where @*@ is a letter of the alphabet (uppercase A to Z)
|
||||
priority :: Parser Priority
|
||||
priority = char '(' *> priorityChar <* char ')'
|
||||
|
|
@ -2,43 +2,91 @@
|
|||
|
||||
module TaskMachine.UI where
|
||||
|
||||
import Data.Monoid
|
||||
--import Data.Monoid
|
||||
--
|
||||
import qualified Brick as B
|
||||
import qualified Brick.AttrMap as B
|
||||
import qualified Brick.Widgets.List as B
|
||||
import qualified Data.Vector as V
|
||||
import qualified Graphics.Vty as VTY
|
||||
|
||||
import qualified Brick as B
|
||||
import qualified Brick.Themes as B
|
||||
import qualified Database.SQLite.Simple as DB
|
||||
import qualified Graphics.Vty as VTY
|
||||
|
||||
import qualified TaskMachine.Config as TM
|
||||
import TaskMachine.TaskList
|
||||
--import qualified Database.SQLite.Simple as DB
|
||||
--import qualified Brick.Themes as B
|
||||
--
|
||||
--import qualified TaskMachine.Config as TM
|
||||
--import qualified TaskMachine.UI.ListScreen as TM
|
||||
|
||||
data ResourceName = Asdf
|
||||
{- Mockup UI
|
||||
|
||||
Purge | Refresh | Search _________
|
||||
----------------------------------
|
||||
(A) do +stuff
|
||||
x (B) and other +stuff
|
||||
|
||||
|
||||
|
||||
---------------------------------
|
||||
Edit _____________________________
|
||||
|
||||
-}
|
||||
|
||||
-- Implementation plan:
|
||||
-- [_] find/create suitable task list implementation
|
||||
-- * keep original todo.txt order
|
||||
-- * edit tasks, delete tasks, append tasks
|
||||
-- * no reordering of tasks necessary
|
||||
-- * sort by different metrics
|
||||
-- * filter by different metrics
|
||||
-- [_] load tasks from file specified in arguments
|
||||
-- * report if file doesn't exist
|
||||
-- * report if incorrect format (parse errors)
|
||||
-- * warn if file only readable
|
||||
-- [_] display loaded tasks in UI
|
||||
|
||||
data RName = RTaskList
|
||||
deriving (Eq, Ord)
|
||||
|
||||
data UIState = UIState
|
||||
{ uiConfig :: TM.Config
|
||||
, uiDBConnection :: DB.Connection
|
||||
, uiScreenState :: ScreenState
|
||||
{ taskList :: B.List RName LTask
|
||||
, invisibleTasks :: V.Vector LTask
|
||||
}
|
||||
|
||||
data ScreenState
|
||||
= Dummy
|
||||
-- = ScreenList TM.ListScreen
|
||||
startState :: UIState
|
||||
startState = UIState (B.list RTaskList V.empty 1) V.empty
|
||||
|
||||
defaultTheme :: B.Theme
|
||||
defaultTheme = B.newTheme VTY.defAttr
|
||||
[ ("taskList" <> "normal", withStyle VTY.bold $ B.fg VTY.cyan)
|
||||
, ("taskList" <> "highlight", B.bg VTY.cyan)
|
||||
]
|
||||
where withStyle = flip VTY.withStyle
|
||||
|
||||
myApp :: B.App () () ResourceName
|
||||
myApp :: B.App UIState () RName
|
||||
myApp = B.App
|
||||
{ B.appDraw = \_ -> [myTestWidget]
|
||||
, B.appHandleEvent = B.resizeOrQuit
|
||||
, B.appStartEvent = \s -> return s
|
||||
{ B.appDraw = const []
|
||||
, B.appChooseCursor = B.neverShowCursor
|
||||
, B.appAttrMap = const $ B.themeToAttrMap defaultTheme
|
||||
, B.appHandleEvent = B.resizeOrQuit
|
||||
, B.appStartEvent = pure
|
||||
, B.appAttrMap = const $ B.attrMap VTY.defAttr []
|
||||
}
|
||||
where
|
||||
myTestWidget = B.withAttr ("taskList" <> "normal") (B.str "normal ") B.<+> B.withAttr ("taskList" <> "highlight") (B.str "style")
|
||||
|
||||
-- { uiConfig :: TM.Config
|
||||
-- , uiDBConnection :: DB.Connection
|
||||
-- , uiScreenState :: ScreenState
|
||||
-- }
|
||||
--
|
||||
--data ScreenState
|
||||
-- = Dummy
|
||||
---- = ScreenList TM.ListScreen
|
||||
--
|
||||
--defaultTheme :: B.Theme
|
||||
--defaultTheme = B.newTheme VTY.defAttr
|
||||
-- [ ("taskList" <> "normal", withStyle VTY.bold $ B.fg VTY.cyan)
|
||||
-- , ("taskList" <> "highlight", B.bg VTY.cyan)
|
||||
-- ]
|
||||
-- where withStyle = flip VTY.withStyle
|
||||
--
|
||||
--myApp :: B.App () () ResourceName
|
||||
--myApp = B.App
|
||||
-- { B.appDraw = \_ -> [myTestWidget]
|
||||
-- , B.appHandleEvent = B.resizeOrQuit
|
||||
-- , B.appStartEvent = \s -> return s
|
||||
-- , B.appChooseCursor = B.neverShowCursor
|
||||
-- , B.appAttrMap = const $ B.themeToAttrMap defaultTheme
|
||||
-- }
|
||||
-- where
|
||||
-- myTestWidget = B.withAttr ("taskList" <> "normal") (B.str "normal ") B.<+> B.withAttr ("taskList" <> "highlight") (B.str "style")
|
||||
|
|
|
|||
|
|
@ -1,42 +0,0 @@
|
|||
module TaskMachine.UI.ListScreen where
|
||||
{-
|
||||
( ListScreen
|
||||
, newListScreen
|
||||
, renderListScreen
|
||||
, updateListScreen
|
||||
) where
|
||||
|
||||
import qualified Brick as B
|
||||
import qualified Brick.Widgets.List as B
|
||||
import Data.Time
|
||||
import qualified Graphics.Vty.Input.Events as VTY
|
||||
import qualified Data.Vector as V
|
||||
import qualified Database.SQLite.Simple as DB
|
||||
|
||||
import qualified TaskMachine.Database as TM
|
||||
import qualified TaskMachine.Task as TM
|
||||
import qualified TaskMachine.UI.Types as TM
|
||||
|
||||
type Res = TM.ResourceName
|
||||
|
||||
newtype ListScreen = ListScreen (B.List Res TM.Task)
|
||||
|
||||
newListScreen :: DB.Connection -> IO ListScreen
|
||||
newListScreen conn = do
|
||||
today <- utctDay <$> getCurrentTime
|
||||
relevant <- map TM.fromTaskRow <$> TM.selectRelevantTasks conn today
|
||||
let sorted = relevant -- TM.sort??? relevant
|
||||
vector = V.fromList sorted
|
||||
list = B.list TM.RTaskList vector 1
|
||||
return $ ListScreen list
|
||||
|
||||
renderTask :: Bool -> TM.Task -> B.Widget Res
|
||||
renderTask _ task = B.txt $ TM.taskDescription task
|
||||
|
||||
renderListScreen :: Bool -> ListScreen -> B.Widget Res
|
||||
renderListScreen focused (ListScreen list) = B.renderList renderTask focused list
|
||||
|
||||
updateListScreen :: VTY.Event -> ListScreen -> B.EventM Res ListScreen
|
||||
updateListScreen event (ListScreen list) =
|
||||
ListScreen <$> B.handleListEventVi B.handleListEvent event list
|
||||
-}
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
module TaskMachine.UI.Types
|
||||
( ResourceName(..)
|
||||
) where
|
||||
|
||||
data ResourceName
|
||||
= RTaskList
|
||||
deriving (Eq, Ord, Show)
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
import Test.Hspec
|
||||
|
||||
import Tests.DateExpr
|
||||
import Tests.Todotxt
|
||||
|
||||
main :: IO ()
|
||||
main = hspec $ do
|
||||
testDateExpr
|
||||
testTodotxt
|
||||
|
|
|
|||
|
|
@ -1,79 +0,0 @@
|
|||
module Tests.DateExpr
|
||||
( testDateExpr
|
||||
) where
|
||||
|
||||
import Data.Time.Calendar
|
||||
|
||||
import Test.Hspec
|
||||
import Test.QuickCheck
|
||||
|
||||
import qualified TaskMachine.DateExpr as TM
|
||||
|
||||
parseEvalInt :: String -> Day -> Maybe Integer
|
||||
parseEvalInt str day = do
|
||||
expr <- TM.parseIntExpr str
|
||||
TM.evalIntExpr expr day
|
||||
|
||||
parseEvalBool :: String -> Day -> Maybe Bool
|
||||
parseEvalBool str day = do
|
||||
expr <- TM.parseBoolExpr str
|
||||
TM.evalBoolExpr expr day
|
||||
|
||||
toDay :: Integer -> Day
|
||||
toDay = ModifiedJulianDay
|
||||
|
||||
anyDay :: Day
|
||||
anyDay = toDay 0
|
||||
|
||||
{-
|
||||
- IntExpr properties
|
||||
-}
|
||||
|
||||
prop_ParseInteger :: Integer -> Property
|
||||
prop_ParseInteger n = parseEvalInt (show n) anyDay === Just n
|
||||
|
||||
prop_ParseAddSub :: Integer -> Integer -> Integer -> Integer -> Property
|
||||
prop_ParseAddSub a b c d =
|
||||
let formula = show a ++ "+" ++ show b ++ "- (" ++ show c ++ "+" ++ show d ++ ")"
|
||||
expected = a + b - (c + d)
|
||||
in parseEvalInt formula anyDay === Just expected
|
||||
|
||||
prop_ParseMultDiv :: Integer -> Integer -> Integer -> Integer -> Property
|
||||
prop_ParseMultDiv a b c d =
|
||||
let formula = show a ++ "*" ++ show b ++ "/ (" ++ show c ++ "*" ++ show d ++ ")"
|
||||
expected = a * b `div` (c * d)
|
||||
in (c * d /= 0) ==> parseEvalInt formula anyDay === Just expected
|
||||
|
||||
prop_ParseComplicated :: Integer -> Integer -> Integer -> Integer -> Integer -> Property
|
||||
prop_ParseComplicated a b c d e =
|
||||
let formula = show a ++ "% -(" ++ show b ++ "/" ++ show c ++ ") +"
|
||||
++ show d ++ "* ((" ++ show e ++ "))"
|
||||
expected = a `mod` (-(b `div` c)) + d * e
|
||||
in (c /= 0 && (b `div` c) /= 0) ==> parseEvalInt formula anyDay === Just expected
|
||||
|
||||
{-
|
||||
- BoolExpr properties
|
||||
-}
|
||||
|
||||
prop_FindWeekends :: Integer -> Property
|
||||
prop_FindWeekends a =
|
||||
let formula = "(weekday == saturday || weekday == sunday) == isweekend"
|
||||
in parseEvalBool formula (toDay a) === Just True
|
||||
|
||||
prop_FindLeapYears :: Integer -> Property
|
||||
prop_FindLeapYears a =
|
||||
let formula = "(year%400 == 0 || (year%4 == 0 && year%100 != 0)) == isleapyear"
|
||||
in parseEvalBool formula (toDay a) === Just True
|
||||
|
||||
testDateExpr :: SpecWith ()
|
||||
testDateExpr = describe "Date expressions" $ do
|
||||
describe "IntExpr" $ do
|
||||
it "parses integers" $ property prop_ParseInteger
|
||||
it "evaluates addition and subtraction" $ property prop_ParseAddSub
|
||||
it "evaluates multiplication and division" $ property prop_ParseMultDiv
|
||||
it "evaluates a complicated equation" $ property prop_ParseComplicated
|
||||
describe "BoolExpr" $ do
|
||||
it "parses \"true\"" $ parseEvalBool "true" anyDay `shouldBe` Just True
|
||||
it "parses \"false\"" $ parseEvalBool "false" anyDay `shouldBe` Just False
|
||||
it "finds weekends" $ property prop_FindWeekends
|
||||
it "finds leap years" $ property prop_FindLeapYears
|
||||
132
test/Tests/Todotxt.hs
Normal file
132
test/Tests/Todotxt.hs
Normal file
|
|
@ -0,0 +1,132 @@
|
|||
module Tests.Todotxt
|
||||
( testTodotxt
|
||||
) where
|
||||
|
||||
import Data.Time.Calendar
|
||||
import Test.Hspec
|
||||
import Test.QuickCheck
|
||||
import Text.Megaparsec
|
||||
|
||||
import TaskMachine.Todotxt
|
||||
|
||||
{- Dates properties -}
|
||||
|
||||
|
||||
instance Bounded Day where -- year stays within 4 digits
|
||||
minBound = fromGregorian 1000 1 1
|
||||
maxBound = fromGregorian 9999 12 31
|
||||
|
||||
instance Arbitrary Day where
|
||||
arbitrary = arbitraryBoundedEnum
|
||||
|
||||
instance Arbitrary Dates where
|
||||
arbitrary = do
|
||||
which <- arbitrary
|
||||
case which of
|
||||
True -> CrDate <$> arbitrary
|
||||
False -> CoCrDate <$> arbitrary <*> arbitrary
|
||||
|
||||
prop_DatesFormatParse :: Dates -> Bool
|
||||
prop_DatesFormatParse d = parseMaybe dates (formatDates d) == Just d
|
||||
|
||||
prop_DatesParseCr :: Day -> Bool
|
||||
prop_DatesParseCr d = parseMaybe dates (show d) == Just (CrDate d)
|
||||
|
||||
prop_DatesParseCoCr :: Day -> Day -> Bool
|
||||
prop_DatesParseCoCr d1 d2 = parseMaybe dates (show d1 ++ " " ++ show d2) == Just (CoCrDate d1 d2)
|
||||
|
||||
{- Priority properties -}
|
||||
|
||||
instance Arbitrary Priority where
|
||||
arbitrary = arbitraryBoundedEnum
|
||||
|
||||
prop_PrioCharPrio :: Priority -> Bool
|
||||
prop_PrioCharPrio p = (charToPriority . priorityToChar) p == Just p
|
||||
|
||||
prop_PrioFormatParse :: Priority -> Bool
|
||||
prop_PrioFormatParse p = parseMaybe priority (formatPriority p) == Just p
|
||||
|
||||
prop_PrioToUppercase :: Priority -> Bool
|
||||
prop_PrioToUppercase p = priorityToChar p `elem` ['A'..'Z']
|
||||
|
||||
{- The tests themselves -}
|
||||
|
||||
testTodotxt :: SpecWith ()
|
||||
testTodotxt = describe "Todotxt" $ do
|
||||
describe "Priority" $ do
|
||||
it "can be converted to a Char and back" $ forAll arbitrary prop_PrioCharPrio
|
||||
it "can be formatted and parsed again" $ forAll arbitrary prop_PrioFormatParse
|
||||
it "is only converted into uppercase characters" $ forAll arbitrary prop_PrioToUppercase
|
||||
describe "Dates" $ do
|
||||
it "can be formatted and parsed again" $ property prop_DatesFormatParse
|
||||
it "parses single dates" $ property prop_DatesParseCr
|
||||
it "parses double dates" $ property prop_DatesParseCoCr
|
||||
|
||||
--parseEvalInt :: String -> Day -> Maybe Integer
|
||||
--parseEvalInt str day = do
|
||||
-- expr <- TM.parseIntExpr str
|
||||
-- TM.evalIntExpr expr day
|
||||
--
|
||||
--parseEvalBool :: String -> Day -> Maybe Bool
|
||||
--parseEvalBool str day = do
|
||||
-- expr <- TM.parseBoolExpr str
|
||||
-- TM.evalBoolExpr expr day
|
||||
--
|
||||
--toDay :: Integer -> Day
|
||||
--toDay = ModifiedJulianDay
|
||||
--
|
||||
--anyDay :: Day
|
||||
--anyDay = toDay 0
|
||||
--
|
||||
--{-
|
||||
-- - IntExpr properties
|
||||
-- -}
|
||||
--
|
||||
--prop_ParseInteger :: Integer -> Property
|
||||
--prop_ParseInteger n = parseEvalInt (show n) anyDay === Just n
|
||||
--
|
||||
--prop_ParseAddSub :: Integer -> Integer -> Integer -> Integer -> Property
|
||||
--prop_ParseAddSub a b c d =
|
||||
-- let formula = show a ++ "+" ++ show b ++ "- (" ++ show c ++ "+" ++ show d ++ ")"
|
||||
-- expected = a + b - (c + d)
|
||||
-- in parseEvalInt formula anyDay === Just expected
|
||||
--
|
||||
--prop_ParseMultDiv :: Integer -> Integer -> Integer -> Integer -> Property
|
||||
--prop_ParseMultDiv a b c d =
|
||||
-- let formula = show a ++ "*" ++ show b ++ "/ (" ++ show c ++ "*" ++ show d ++ ")"
|
||||
-- expected = a * b `div` (c * d)
|
||||
-- in (c * d /= 0) ==> parseEvalInt formula anyDay === Just expected
|
||||
--
|
||||
--prop_ParseComplicated :: Integer -> Integer -> Integer -> Integer -> Integer -> Property
|
||||
--prop_ParseComplicated a b c d e =
|
||||
-- let formula = show a ++ "% -(" ++ show b ++ "/" ++ show c ++ ") +"
|
||||
-- ++ show d ++ "* ((" ++ show e ++ "))"
|
||||
-- expected = a `mod` (-(b `div` c)) + d * e
|
||||
-- in (c /= 0 && (b `div` c) /= 0) ==> parseEvalInt formula anyDay === Just expected
|
||||
--
|
||||
--{-
|
||||
-- - BoolExpr properties
|
||||
-- -}
|
||||
--
|
||||
--prop_FindWeekends :: Integer -> Property
|
||||
--prop_FindWeekends a =
|
||||
-- let formula = "(weekday == saturday || weekday == sunday) == isweekend"
|
||||
-- in parseEvalBool formula (toDay a) === Just True
|
||||
--
|
||||
--prop_FindLeapYears :: Integer -> Property
|
||||
--prop_FindLeapYears a =
|
||||
-- let formula = "(year%400 == 0 || (year%4 == 0 && year%100 != 0)) == isleapyear"
|
||||
-- in parseEvalBool formula (toDay a) === Just True
|
||||
--
|
||||
--testDateExpr :: SpecWith ()
|
||||
--testDateExpr = describe "Date expressions" $ do
|
||||
-- describe "IntExpr" $ do
|
||||
-- it "parses integers" $ property prop_ParseInteger
|
||||
-- it "evaluates addition and subtraction" $ property prop_ParseAddSub
|
||||
-- it "evaluates multiplication and division" $ property prop_ParseMultDiv
|
||||
-- it "evaluates a complicated equation" $ property prop_ParseComplicated
|
||||
-- describe "BoolExpr" $ do
|
||||
-- it "parses \"true\"" $ parseEvalBool "true" anyDay `shouldBe` Just True
|
||||
-- it "parses \"false\"" $ parseEvalBool "false" anyDay `shouldBe` Just False
|
||||
-- it "finds weekends" $ property prop_FindWeekends
|
||||
-- it "finds leap years" $ property prop_FindLeapYears
|
||||
Loading…
Add table
Add a link
Reference in a new issue