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
|
module Main where
|
||||||
|
|
||||||
import Control.Applicative
|
|
||||||
import Control.Exception
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Data.List
|
|
||||||
--import Data.Maybe
|
|
||||||
import System.Exit
|
|
||||||
import System.IO.Error
|
|
||||||
|
|
||||||
import qualified Brick.Themes as B
|
import qualified Brick 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 TaskMachine.Config as TM
|
import TaskMachine.UI
|
||||||
--import qualified TaskMachine.Database as TM
|
|
||||||
--import qualified TaskMachine.DateExpr as TM
|
|
||||||
import qualified TaskMachine.UI as TM
|
|
||||||
|
|
||||||
-- TODO: When adding oConfigFile back, make oTaskDB a Maybe FilePath.
|
main :: IO()
|
||||||
-- This way, it won't always overwrite the task db set in the config.
|
main = void $ B.defaultMain myApp startState
|
||||||
-- 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...)"
|
|
||||||
|
|
|
||||||
11
package.yaml
11
package.yaml
|
|
@ -22,18 +22,19 @@ description: Please see the README on Github at <https://github.com/Garm
|
||||||
dependencies:
|
dependencies:
|
||||||
- base >= 4.7 && < 5
|
- base >= 4.7 && < 5
|
||||||
- brick
|
- brick
|
||||||
- ConfigFile
|
|
||||||
- containers
|
- containers
|
||||||
- megaparsec
|
- megaparsec
|
||||||
- optparse-applicative
|
|
||||||
- sqlite-simple
|
|
||||||
- text
|
|
||||||
- time
|
- time
|
||||||
- unix
|
|
||||||
- vector
|
- vector
|
||||||
- vty
|
- vty
|
||||||
|
# tests
|
||||||
- hspec
|
- hspec
|
||||||
- QuickCheck
|
- QuickCheck
|
||||||
|
#- ConfigFile
|
||||||
|
#- optparse-applicative
|
||||||
|
#- sqlite-simple
|
||||||
|
#- text
|
||||||
|
#- unix
|
||||||
#- unordered-containers
|
#- unordered-containers
|
||||||
#- transformers
|
#- transformers
|
||||||
#- async
|
#- 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
|
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 TaskMachine.TaskList
|
||||||
import qualified Brick.Themes as B
|
--import qualified Database.SQLite.Simple as DB
|
||||||
import qualified Database.SQLite.Simple as DB
|
--import qualified Brick.Themes as B
|
||||||
import qualified Graphics.Vty as VTY
|
--
|
||||||
|
--import qualified TaskMachine.Config as TM
|
||||||
import qualified TaskMachine.Config as TM
|
|
||||||
--import qualified TaskMachine.UI.ListScreen 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)
|
deriving (Eq, Ord)
|
||||||
|
|
||||||
data UIState = UIState
|
data UIState = UIState
|
||||||
{ uiConfig :: TM.Config
|
{ taskList :: B.List RName LTask
|
||||||
, uiDBConnection :: DB.Connection
|
, invisibleTasks :: V.Vector LTask
|
||||||
, uiScreenState :: ScreenState
|
|
||||||
}
|
}
|
||||||
|
|
||||||
data ScreenState
|
startState :: UIState
|
||||||
= Dummy
|
startState = UIState (B.list RTaskList V.empty 1) V.empty
|
||||||
-- = ScreenList TM.ListScreen
|
|
||||||
|
|
||||||
defaultTheme :: B.Theme
|
myApp :: B.App UIState () RName
|
||||||
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
|
myApp = B.App
|
||||||
{ B.appDraw = \_ -> [myTestWidget]
|
{ B.appDraw = const []
|
||||||
, B.appHandleEvent = B.resizeOrQuit
|
|
||||||
, B.appStartEvent = \s -> return s
|
|
||||||
, B.appChooseCursor = B.neverShowCursor
|
, 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 Test.Hspec
|
||||||
|
|
||||||
import Tests.DateExpr
|
import Tests.Todotxt
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = hspec $ do
|
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