From bff0656806db7776abbac1357307d976e34b42ca Mon Sep 17 00:00:00 2001 From: Joscha Date: Wed, 4 Apr 2018 22:18:04 +0000 Subject: [PATCH] Make project compile again This commit also adds a few other files that I've been working on, although most of it will get deleted again. This is just so I have them logged in git. --- app/Main.hs | 19 ++++--- package.yaml | 1 + src/TaskMachine/Database.hs | 9 +++- src/TaskMachine/Task.hs | 93 ++++++++++++++++++++++++++++++++ src/TaskMachine/UI.hs | 30 +++++++---- src/TaskMachine/UI/ListScreen.hs | 42 +++++++++++++++ src/TaskMachine/UI/Types.hs | 7 +++ 7 files changed, 180 insertions(+), 21 deletions(-) create mode 100644 src/TaskMachine/Task.hs create mode 100644 src/TaskMachine/UI/ListScreen.hs create mode 100644 src/TaskMachine/UI/Types.hs diff --git a/app/Main.hs b/app/Main.hs index d752d1c..f269601 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -6,22 +6,22 @@ import Control.Applicative import Control.Exception import Control.Monad import Data.List -import Data.Maybe +--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 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 qualified TaskMachine.Database as TM -import qualified TaskMachine.DateExpr as TM +--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. @@ -208,7 +208,7 @@ main = do -- ... and initialize db act $ "Using db at " ++ show (TM.cTaskDB config) ++ "." DB.withConnection (TM.cTaskDB config) $ \c -> do - TM.initializeNewDB c + --TM.initializeNewDB c -- TESTING testDB c @@ -217,7 +217,8 @@ main = do error "Implement UI" theme config testDB :: DB.Connection -> IO () -testDB c = do +testDB _ = do + {- now <- utctDay <$> getCurrentTime let deadlineBefore = Just $ addDays (-2) now deadlineAfter = Just $ addDays 2 now @@ -242,3 +243,5 @@ testDB c = do putStrLn "RELEVANT TASKS" tasks2 <- TM.selectRelevantTasks c now forM_ tasks2 $ print . TM.rowDescription + -} + putStrLn "Everything works (because there's nothing here...)" diff --git a/package.yaml b/package.yaml index 36f4bdb..fbf8ed8 100644 --- a/package.yaml +++ b/package.yaml @@ -29,6 +29,7 @@ dependencies: - text - time - unix +- vector - vty - hspec - QuickCheck diff --git a/src/TaskMachine/Database.hs b/src/TaskMachine/Database.hs index f83efef..6c8dc30 100644 --- a/src/TaskMachine/Database.hs +++ b/src/TaskMachine/Database.hs @@ -1,10 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -module TaskMachine.Database +module TaskMachine.Database where +{- ( TaskRow(..) , IntFormula(..) , BoolFormula(..) + , TaskID + , Duration , initializeNewDB , updateTasks , selectRelevantTasks @@ -58,11 +61,12 @@ instance DB.FromField BoolFormula where Just expr -> DB.Ok BoolFormula{ boolFormulaText = text, boolFormulaExpr = expr } type TaskID = Integer +type Duration = Integer data TaskRow = TaskRow { rowID :: TaskID , rowDeadline :: Maybe Day - , rowDuration :: Integer -- If there is no deadline, the duration is irrelevant + , 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 @@ -228,3 +232,4 @@ doTask c taskID = DB.execute c incrementTotal (DB.Only taskID) \ SET repetitions_done = repetitions_done + 1\ \ WHERE id = ?\ \ AND repetitions_done < repetitions_total" +-} diff --git a/src/TaskMachine/Task.hs b/src/TaskMachine/Task.hs new file mode 100644 index 0000000..244302a --- /dev/null +++ b/src/TaskMachine/Task.hs @@ -0,0 +1,93 @@ +{-# 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(..) + , Subtask(..) + ) where + +import qualified Data.Text as T + +import qualified TaskMachine.DateExpr as TM +import qualified TaskMachine.Deadline as TM + +type SubtaskID = Integer + +data Subtask = Subtask + { subID :: SubtaskID + , subLabel :: T.Text + , subRepetitionsTotal :: Integer + , subRepetitionsDone :: Integer + } + +type TaskID = Integer + +data Task = Task + { taskID :: TaskID + , taskDeadlines :: [TM.Deadline] + , taskFormula :: Maybe TM.IntExpr + , taskDescription :: T.Text + , taskDetails :: T.Text + , taskSubtasks :: [Subtask] + } + +{- + ( 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 +-} diff --git a/src/TaskMachine/UI.hs b/src/TaskMachine/UI.hs index ebf86a3..24c1e6e 100644 --- a/src/TaskMachine/UI.hs +++ b/src/TaskMachine/UI.hs @@ -4,11 +4,26 @@ module TaskMachine.UI where import Data.Monoid -import qualified Brick as B -import qualified Brick.Themes as B -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 qualified TaskMachine.Config as TM +--import qualified TaskMachine.UI.ListScreen as TM + +data ResourceName = Asdf + deriving (Eq, Ord) + +data UIState = UIState + { uiConfig :: TM.Config + , uiDBConnection :: DB.Connection + , uiScreenState :: ScreenState + } + +data ScreenState + = Dummy +-- = ScreenList TM.ListScreen defaultTheme :: B.Theme defaultTheme = B.newTheme VTY.defAttr @@ -17,13 +32,6 @@ defaultTheme = B.newTheme VTY.defAttr ] where withStyle = flip VTY.withStyle -data ResourceName = Asdf - deriving (Eq, Ord) - -data State = State - { sConfig :: TM.Config - } - myApp :: B.App () () ResourceName myApp = B.App { B.appDraw = \_ -> [myTestWidget] diff --git a/src/TaskMachine/UI/ListScreen.hs b/src/TaskMachine/UI/ListScreen.hs new file mode 100644 index 0000000..642e3b1 --- /dev/null +++ b/src/TaskMachine/UI/ListScreen.hs @@ -0,0 +1,42 @@ +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 +-} diff --git a/src/TaskMachine/UI/Types.hs b/src/TaskMachine/UI/Types.hs new file mode 100644 index 0000000..4effb20 --- /dev/null +++ b/src/TaskMachine/UI/Types.hs @@ -0,0 +1,7 @@ +module TaskMachine.UI.Types + ( ResourceName(..) + ) where + +data ResourceName + = RTaskList + deriving (Eq, Ord, Show)