diff --git a/app/Main.hs b/app/Main.hs index 2ab1a4c..2a00cca 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,5 +1,6 @@ module Main where +{- import Control.Applicative import Control.Monad @@ -35,3 +36,7 @@ main = do case result of Left parseError -> putStrLn parseError Right tasks -> void $ B.defaultMain (myApp defaultTheme) (startUIState tasks) +-} + +main :: IO () +main = putStrLn "Hello world again" diff --git a/format.txt b/format.txt new file mode 100644 index 0000000..3c932c4 --- /dev/null +++ b/format.txt @@ -0,0 +1,2 @@ +-[ ][ d][ c] +x[][ ][ d][ c] diff --git a/package.yaml b/package.yaml index 95ca558..c538d6a 100644 --- a/package.yaml +++ b/package.yaml @@ -21,27 +21,27 @@ description: Please see the README on Github at = 4.7 && < 5 -- brick + #- ConfigFile + #- aeson + #- async + #- brick + #- bytestring - containers - megaparsec -- optparse-applicative -- text-zipper + #- optparse-applicative + #- sqlite-simple + #- stm + #- text + #- text-zipper - time -- vector -- vty + #- transformers + #- unix + #- unordered-containers + #- vector + #- vty # tests - hspec - QuickCheck - #- ConfigFile - #- sqlite-simple - #- text - #- unix - #- unordered-containers - #- transformers - #- async - #- aeson - #- bytestring - #- stm library: source-dirs: src diff --git a/src/TaskMachine/LTask.hs b/src/TaskMachine/LTask.hs deleted file mode 100644 index 10ecc98..0000000 --- a/src/TaskMachine/LTask.hs +++ /dev/null @@ -1,39 +0,0 @@ --- | A way to store the 'Task's that preserves the original task order. - -module TaskMachine.LTask - ( LTask(..) - , fromTasks - , loadLTasks - , saveLTasks - ) where - -import Data.Function -import Data.List - -import qualified Data.Vector as V - -import TaskMachine.Todotxt - --- | A "ListTask" for use in the task list -data LTask = LTask - { ltaskNumber :: Integer - -- ^ Sort by this number to get the original order of the tasks - , ltaskTask :: Task - -- ^ The 'Task' itself - } deriving (Show) - -fromTasks :: [Task] -> [LTask] -fromTasks = zipWith LTask [1..] - -loadLTasks :: FilePath -> IO (Either String (V.Vector LTask)) -loadLTasks file = do - content <- readFile file - case parseTasks file content of - Right taskList -> pure $ Right $ V.fromList $ fromTasks taskList - Left parseError -> pure $ Left $ show parseError - -saveLTasks :: V.Vector LTask -> FilePath -> IO () -saveLTasks ltasks file = do - let taskList = map ltaskTask $ sortBy (compare `on` ltaskNumber) $ V.toList ltasks - text = unlines $ map formatTask taskList - writeFile file text diff --git a/src/TaskMachine/Task.hs b/src/TaskMachine/Task.hs new file mode 100644 index 0000000..4203ac4 --- /dev/null +++ b/src/TaskMachine/Task.hs @@ -0,0 +1,238 @@ +-- | Read, parse and write tasks in a human-readable format +-- +-- The format used by this module is inspired by the +-- +-- and attempts to follow similar goals: +-- +-- 1. A single line represents a single task +-- 2. Should be entirely human-readable and easily editable using a simple text viewer/editor +-- 3. When sorted alphabetically, should yield useful results +-- 4. Completing a task is as simple as changing the @-@ into a @x@ + +module TaskMachine.Task + ( Task(..) + , Completion(..) + , Priority(..) + , priorityToChar + , charToPriority + , Description + , Snippet(..) + -- * Formatting + , formatTask + , formatDate + , formatCompletion + , formatPriority + , formatDescription + -- * Parsing + -- ** Utilities + , Parser + , andSpace + , maybeParse + -- ** Objects + , pTask + , pTasks + , pDate + , pCompletion + , pPriorityChar + , pPriority + , pDueDate + , pCreationDate + , pDescription + ) where + +import Control.Applicative (liftA2) +import Control.Monad +import qualified Data.List.NonEmpty as NE +import Data.Void + +import qualified Data.Set as Set +import Data.Time.Calendar +import Text.Megaparsec +import Text.Megaparsec.Char + +{- Task -} + +data Task = Task + { taskCompleted :: Completion + , taskPriority :: Maybe Priority + , taskDue :: Maybe Day + , taskCreated :: Maybe Day + , taskDescription :: Description + } deriving (Show) + +formatTask :: Task -> String +formatTask t + = formatCompletion (taskCompleted t) ++ " " + ++ maybeWithSpace formatPriority (taskPriority t) + ++ maybeWithSpace formatDate (taskDue t) + ++ maybeWithSpace formatDate (taskCreated t) + ++ formatDescription (taskDescription t) + where + maybeWithSpace :: (a -> String) -> Maybe a -> String + maybeWithSpace _ Nothing = "" + maybeWithSpace f (Just a) = f a ++ " " + +--parseTasks :: FilePath -> String -> Either (ParseError Char Void) [Task] +--parseTasks = parse pTasks -- That's easy! + +{- Dates -} + +formatDate :: Day -> String +formatDate = show + +{- Completion -} + +data Completion + = Incomplete + | Complete (Maybe Day) + deriving (Show) + +formatCompletion :: Completion -> String +formatCompletion Incomplete = "-" +formatCompletion (Complete Nothing) = "x" +formatCompletion (Complete (Just day)) = "x " ++ formatDate 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) + +formatPriority :: Priority -> String +formatPriority p = '(' : priorityToChar p : ")" + +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) + +{- Description -} + +type Description = [Snippet] + +data Snippet + = Word String + | Space String + | Project String + | Context String + | KeyValue String String + deriving (Eq, Show) + +formatDescription :: Description -> String +formatDescription = concatMap toString + where + toString :: Snippet -> String + toString (Word s) = s + toString (Space s) = s + toString (Project s) = '+' : s + toString (Context s) = '@' : s + toString (KeyValue k v) = k ++ ":" ++ v + +{- Parsing -} + +type Parser = Parsec Void String + +-- Completion + +pDate :: Parser Day +pDate = label "date" $ fromGregorian + <$> integer + <*> (char '-' *> int) + <*> (char '-' *> int) + where + integer :: Parser Integer + integer = read <$> count 4 digitChar + int :: Parser Int + int = read <$> count 2 digitChar + +pCompletion :: Parser Completion +pCompletion = Incomplete <$ char '-' + <|> char 'x' *> (Complete <$> maybeParse pDate) + +-- Priority +pPriorityChar :: Parser Priority +pPriorityChar = do + c <- anyChar + case charToPriority c of + Just p -> pure p + Nothing -> failure (Just $ Tokens $ c NE.:| []) + (Set.singleton $ Label $ 'p' NE.:| "riority character") + +pPriority :: Parser Priority +pPriority = char '(' *> pPriorityChar <* char ')' + +-- Dates + +pDueDate :: Parser Day +pDueDate = char 'd' *> pDate + +pCreationDate :: Parser Day +pCreationDate = char 'c' *> pDate + +-- Description + +wordBody :: Parser String +wordBody = takeWhile1P (Just "word character") (not . (`elem` " \n")) + +pWord :: Parser Snippet +pWord = Word <$> wordBody + +pSpace :: Parser Snippet +pSpace = Space <$> takeWhile1P (Just "space") (==' ') + +pProject :: Parser Snippet +pProject = char '+' *> (Project <$> wordBody) + +pContext :: Parser Snippet +pContext = char '@' *> (Context <$> wordBody) + +pKeyValue :: Parser Snippet +pKeyValue = KeyValue <$> (keyBody <* char ':') <*> wordBody + where + keyBody = takeWhile1P (Just "key character") (not . (`elem` ": \n")) + +pDescription :: Parser Description +pDescription = pSnippet + where + pEnd :: Parser Description + pEnd + = [] <$ (eof <|> void (char '\n')) + <|> pSnippet + pSnippet :: Parser Description + pSnippet + = try (liftA2 (:) pSpace pEnd) + <|> try (liftA2 (:) pProject pEnd) + <|> try (liftA2 (:) pContext pEnd) + <|> try (liftA2 (:) pKeyValue pEnd) + <|> liftA2 (:) pWord pEnd + "description" + +-- Task + +andSpace :: Parser a -> Parser a +andSpace = (<* char ' ') + +maybeParse :: Parser a -> Parser (Maybe a) +maybeParse p = Just <$> try p <|> pure Nothing + +pTask :: Parser Task +pTask + = Task + <$> andSpace pCompletion + <*> maybeParse (andSpace pPriority) + <*> maybeParse (andSpace pDueDate) + <*> maybeParse (andSpace pCreationDate) + <*> pDescription + +pTasks :: Parser [Task] +pTasks = many pTask <* eof diff --git a/src/TaskMachine/Todotxt.hs b/src/TaskMachine/Todotxt.hs deleted file mode 100644 index 6145d3d..0000000 --- a/src/TaskMachine/Todotxt.hs +++ /dev/null @@ -1,158 +0,0 @@ --- | Read, parse and write tasks in the format. - -module TaskMachine.Todotxt - ( - -- * Tasks - Task(..) - , formatTask - , parseTasks - -- * Creation and deletion dates - , Dates(..) - , formatDates - -- * Task priority - , Priority(..) - , formatPriority - , priorityToChar - , charToPriority - -- * Parsing - , Parser - , pTask - , pTasks - , pDay - , pDates - , pPriorityChar - , pPriority - , andSpace - , maybeParse - , untilEndOfLine - ) 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 - -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 -} - -pDay :: Parser Day -pDay = label "date" $ fromGregorian - <$> integer - <*> (char '-' *> int) - <*> (char '-' *> int) - where - integer :: Parser Integer - integer = read <$> count 4 digitChar - int :: Parser Int - int = read <$> count 2 digitChar - -pDates :: Parser Dates -pDates = try datesCrCo <|> datesCr - where - datesCrCo :: Parser Dates - datesCrCo = CoCrDate <$> (pDay <* char ' ') <*> pDay - datesCr :: Parser Dates - datesCr = CrDate <$> pDay - -{- 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 -} - -pPriorityChar :: Parser Priority -pPriorityChar = do - c <- anyChar - case charToPriority c of - Just p -> pure p - Nothing -> failure (Just $ Tokens $ c :| []) - (Set.singleton $ Label $ 'p' :| "riority character") - -pPriority :: Parser Priority -pPriority = char '(' *> pPriorityChar <* 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 - -parseTasks :: FilePath -> String -> Either (ParseError Char Void) [Task] -parseTasks = parse pTasks -- hehe - -{- 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') - -pTask :: Parser Task -pTask = Task - <$> boolParse (andSpace completed) - <*> maybeParse (andSpace pPriority) - <*> maybeParse (andSpace pDates) - <*> untilEndOfLine - -pTasks :: Parser [Task] -pTasks = many $ pTask <* (eof <|> void (char '\n')) diff --git a/src/TaskMachine/UI.hs b/src/TaskMachine/UI.hs deleted file mode 100644 index bf69f21..0000000 --- a/src/TaskMachine/UI.hs +++ /dev/null @@ -1,109 +0,0 @@ -module TaskMachine.UI where - ---import Data.Monoid --- -import qualified Brick as B -import qualified Brick.Focus as B -import qualified Brick.Themes as B -import qualified Graphics.Vty.Input.Events as VTY - -import TaskMachine.UI.NewTask -import TaskMachine.UI.TaskList -import TaskMachine.UI.TopBar -import TaskMachine.UI.Types ---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 - -{- 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 - -drawBaseLayer :: UIState -> B.Widget RName -drawBaseLayer s = B.vBox [placeholderTopBar, renderTaskList s, placeholderNewTask] - -drawUIState :: UIState -> [B.Widget RName] -drawUIState s@UIState{errorPopup=Just p} = [renderPopup p, drawBaseLayer s] -drawUIState s = [drawBaseLayer s] - -updateUIState :: UIState -> B.BrickEvent RName () -> B.EventM RName (B.Next UIState) --- Closing any popups -updateUIState s@UIState{errorPopup=Just _} (B.VtyEvent (VTY.EvKey VTY.KEnter [])) = B.continue s{errorPopup=Nothing} -updateUIState s@UIState{errorPopup=Just _} (B.VtyEvent (VTY.EvKey VTY.KEsc [])) = B.continue s{errorPopup=Nothing} ---updateUIState s@UIState{errorPopup=Just p} (B.VtyEvent e) = do --- newPopup <- handlePopupEvent e p --- B.continue s{errorPopup=Just newPopup} --- If there's no password -updateUIState s e = - case B.focusGetCurrent (focus s) of - Nothing -> B.halt s - (Just BRTopBar) -> placeholderUpdate s e - (Just BRTaskList) -> updateTaskList s e - (Just BRNewTask) -> placeholderUpdate s e - -placeholderUpdate :: UIState -> B.BrickEvent RName () -> B.EventM RName (B.Next UIState) -placeholderUpdate s (B.VtyEvent (VTY.EvKey VTY.KEsc [])) = B.halt s -placeholderUpdate s _ = B.continue s - -myApp :: B.Theme -> B.App UIState () RName -myApp theme = B.App - { B.appDraw = drawUIState - , B.appChooseCursor = B.showFirstCursor - , B.appHandleEvent = updateUIState - , B.appStartEvent = pure - , B.appAttrMap = const attrMap - } - where - attrMap = B.themeToAttrMap theme - --- { 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") diff --git a/src/TaskMachine/UI/Colortest.hs b/src/TaskMachine/UI/Colortest.hs deleted file mode 100644 index ea0954d..0000000 --- a/src/TaskMachine/UI/Colortest.hs +++ /dev/null @@ -1,135 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | A collection of types necessary for the UI. --- --- These were put in a separate module to avoid an import cycle. - -module TaskMachine.UI.Colortest where - -import Control.Monad -import Data.List - -import qualified Brick as B -import qualified Graphics.Vty as VTY - -colors :: [(String, VTY.Color)] -colors = - [ ("black", VTY.black) - , ("red", VTY.red) - , ("green", VTY.green) - , ("yellow", VTY.yellow) - , ("blue", VTY.blue) - , ("magenta", VTY.magenta) - , ("cyan", VTY.cyan) - , ("white", VTY.white) - , ("brightBlack", VTY.brightBlack) - , ("brightRed", VTY.brightRed) - , ("brightGreen", VTY.brightGreen) - , ("brightYellow", VTY.brightYellow) - , ("brightBlue", VTY.brightBlue) - , ("brightMagenta", VTY.brightMagenta) - , ("brightCyan", VTY.brightCyan) - , ("brightWhite", VTY.brightWhite) - ] - -styles :: [(String, VTY.Style)] -styles = - [ ("standout", VTY.standout) - , ("underline", VTY.underline) --- , ("reverseVideo", VTY.reverseVideo) --- , ("blink", VTY.blink) --- , ("dim", VTY.dim) - , ("bold", VTY.bold) - ] - -toName :: String -> String -> String -> B.AttrName -toName a b c = B.attrName a <> B.attrName b <> B.attrName c - -useStyles :: [VTY.Style] -> VTY.Attr -> VTY.Attr -useStyles = foldr ((.) . flip VTY.withStyle) id - -attrMap :: B.AttrMap -attrMap = B.attrMap VTY.defAttr $ do - (fgName, fgColor) <- colors - (bgName, bgColor) <- colors - styleList <- subsequences styles - let styleName = concatMap fst styleList - name = toName styleName bgName fgName - fgAttr = VTY.withForeColor VTY.defAttr fgColor - bgAttr = VTY.withBackColor fgAttr bgColor - attr = useStyles (map snd styleList) bgAttr - pure (name, attr) - -cw :: String -> B.Widget n -cw style = B.vBox $ B.str (' ':style) : do - (bgName, _) <- colors - pure $ B.hBox $ do - (fgName, _) <- colors - let name = toName style bgName fgName - pure $ B.withAttr name $ B.str "Hi" - -testWidget :: B.Widget n -testWidget = B.vBox - [ B.hBox [cw "", cw "standout"] - , B.hBox [cw "", cw "underline"] --- , B.hBox [cw "", cw "reverseVideo"] --- , B.hBox [cw "", cw "blink"] --- , B.hBox [cw "", cw "dim"] - , B.hBox [cw "", cw "bold"] - ] - ---fgAttrs :: [(B.AttrName, VTY.Attr)] ---fgAttrs = map toFGAttr colors --- where --- toFGAttr :: (String, VTY.Color) -> (B.AttrName, VTY.Attr) --- toFGAttr (s, c) = (toFGName s, VTY.withForeColor VTY.currentAttr c) --- ---bgAttrs :: [(B.AttrName, VTY.Attr)] ---bgAttrs = map toBGAttr colors --- where --- toBGAttr :: (String, VTY.Color) -> (B.AttrName, VTY.Attr) --- toBGAttr (s, c) = (toBGName s, VTY.withBackColor VTY.currentAttr c) --- ---styleAttrs :: [(B.AttrName, VTY.Attr)] ---styleAttrs = map toStyleAttr styles --- where --- toStyleAttr :: (String, VTY.Style) -> (B.AttrName, VTY.Attr) --- toStyleAttr (s, st) = (toStyleName s, VTY.withStyle VTY.currentAttr st) --- ---attrMap :: B.AttrMap ---attrMap = B.attrMap VTY.defAttr $ concat [fgAttrs, bgAttrs, styleAttrs] --- ---colorWidget :: B.Widget n ---colorWidget = B.vBox $ do --- (bgName, _) <- colors --- let name = toBGName bgName --- pure $ B.withAttr name $ B.hBox $ do --- (fgName, _) <- colors --- let name = toFGName fgName --- pure $ B.withAttr name $ B.str "Hi" --- ---testWidget :: B.Widget n ---testWidget = B.vBox $ do --- (styleName, _) <- styles --- let label = B.str styleName --- name = toStyleName styleName --- widget = B.withAttr name colorWidget --- pure $ B.vBox [B.str "", label, widget] ----- sStyles <- subsequences styles ----- let label = B.str . concat . intercalate ", " . map fst $ sStyles ----- styleMod = foldr (.) id $ map (flip VTY.withStyle . snd) sStyles ----- attr = styleMod VTY.defAttr ----- widget = B.withAttr colorWidget ----- pure $ B.vBox [B.str "", label, widget] - -colorTestMain :: IO () -colorTestMain = void $ B.defaultMain app () - where - app :: B.App () () () - app = B.App - { B.appDraw = const [testWidget] - , B.appChooseCursor = B.neverShowCursor - , B.appHandleEvent = B.resizeOrQuit - , B.appStartEvent = pure - , B.appAttrMap = const attrMap - } diff --git a/src/TaskMachine/UI/NewTask.hs b/src/TaskMachine/UI/NewTask.hs deleted file mode 100644 index ca119ff..0000000 --- a/src/TaskMachine/UI/NewTask.hs +++ /dev/null @@ -1,8 +0,0 @@ -module TaskMachine.UI.NewTask where - -import qualified Brick as B - -import TaskMachine.UI.Types - -placeholderNewTask :: B.Widget RName -placeholderNewTask = B.str "New: " B.<+> B.vLimit 1 (B.fill '_') diff --git a/src/TaskMachine/UI/TaskList.hs b/src/TaskMachine/UI/TaskList.hs deleted file mode 100644 index e724698..0000000 --- a/src/TaskMachine/UI/TaskList.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module TaskMachine.UI.TaskList where - -import Data.Void - -import qualified Brick as B -import qualified Brick.Focus as B -import qualified Brick.Widgets.Edit as B -import qualified Brick.Widgets.List as B -import qualified Data.Text.Zipper as T -import qualified Graphics.Vty as VTY -import Text.Megaparsec - -import TaskMachine.LTask -import TaskMachine.Todotxt -import TaskMachine.UI.Types - -{- -widgetPriority :: B.AttrName -> Maybe Priority -> B.Widget n -widgetPriority _ Nothing = B.emptyWidget -widgetPriority highlight (Just prio) = - let attrName = highlight <> "priority" <> B.attrName [priorityToChar prio] - text = formatPriority prio ++ " " - in B.withAttr attrName $ B.str text - -widgetDescription :: B.AttrName -> String -> B.Widget n -widgetDescription highlight desc = - let attrName = highlight <> "description" - in B.withAttr attrName $ B.str desc - -renderLTask :: Bool -> LTask -> B.Widget RName -renderLTask highlight (LTask _ Task{..}) = - let attrHighlight = if highlight then "highlight" else "normal" - wCompleted = B.str $ if taskCompleted then "x " else " " - wPriority = widgetPriority attrHighlight taskPriority - wDescription = widgetDescription attrHighlight taskDescription - in B.hBox [wCompleted, wPriority, wDescription] --} - ---type Editor = B.Editor String RName ---type TaskList = B.List RName LTask - -{- Rendering -} - -renderLTask :: Maybe (B.Editor String RName) -> Bool -> LTask -> B.Widget RName -renderLTask _ False (LTask _ t) = B.str $ formatTask t -renderLTask Nothing True (LTask _ t) = B.str $ formatTask t -renderLTask (Just edit) True _ = B.renderEditor (B.str . unlines) True edit - -renderTaskList :: UIState -> B.Widget RName -renderTaskList s = - let inFocus = B.focusGetCurrent (focus s) == Just BRTaskList - in B.renderList (renderLTask (taskEdit s)) inFocus (taskList s) - -{- Editing tasks -} - -toEditText :: Task -> String -toEditText Task{taskPriority=Nothing, taskDescription=d} = d -toEditText Task{taskPriority=Just p, taskDescription=d} = formatPriority p ++ " " ++ d - -pEditText :: Parser (Maybe Priority, String) -pEditText = (,) <$> maybeParse (andSpace pPriority) <*> untilEndOfLine - -parseEditText :: String -> Either (ParseError Char Void) (Maybe Priority, String) -parseEditText = parse pEditText "edited task" - -{- Updating state -} - -startEdit :: UIState -> UIState -startEdit s = - case B.listSelectedElement (taskList s) of - Nothing -> s - Just (_, LTask _ t) -> - let edit = B.editor RTaskEdit (Just 1) (toEditText t) - in s{taskEdit=Just edit} - -finishEdit :: UIState -> UIState -finishEdit s@UIState{taskEdit=Just edit} = - case B.getEditContents edit of - [line] -> case parseEditText line of - Right (prio, desc) -> - let changeTask (LTask n t) = LTask n t{taskPriority=prio, taskDescription=desc} - newList = B.listModify changeTask (taskList s) - in s{taskList=newList, taskEdit=Nothing} - - Left parseError -> s{errorPopup=Just $ popup "Parse error" (parseErrorTextPretty parseError)} - _ -> s{errorPopup=Just $ popup "Empty editor" "Enter a task description."} -finishEdit s = s - -updateEditor :: B.Editor String RName -> VTY.Event -> B.EventM RName (B.Editor String RName) -updateEditor edit (VTY.EvKey VTY.KHome []) = pure $ B.applyEdit T.gotoBOL edit -updateEditor edit (VTY.EvKey VTY.KEnd []) = pure $ B.applyEdit T.gotoEOL edit -updateEditor edit e = B.handleEditorEvent e edit - - -updateTaskList :: UIState -> B.BrickEvent RName () -> B.EventM RName (B.Next UIState) --- Exit application -updateTaskList s@UIState{taskEdit=Nothing} (B.VtyEvent (VTY.EvKey VTY.KEsc [])) = B.halt s - -{- --- Test stuff -updateTaskList s e = do - let changeTask (LTask n t) = LTask n t{taskDescription=show e} - newList = B.listModify changeTask (taskList s) - B.continue s{taskList=newList} --} - --- Scroll focus -updateTaskList s (B.VtyEvent (VTY.EvKey VTY.KBackTab [])) = B.continue $ bigFocusPrev s -updateTaskList s (B.VtyEvent (VTY.EvKey (VTY.KChar '\t') [])) = B.continue $ bigFocusNext s --- Start editing the current task -updateTaskList s@UIState{taskEdit=Nothing} (B.VtyEvent (VTY.EvKey (VTY.KChar 'e') [])) = B.continue $ startEdit s --- Update the task list -updateTaskList s@UIState{taskEdit=Nothing} (B.VtyEvent e) = do - newList <- B.handleListEventVi B.handleListEvent e (taskList s) - B.continue s{taskList=newList} --- Exit the editor (losing all changes) -updateTaskList s@UIState{taskEdit=Just _} (B.VtyEvent (VTY.EvKey VTY.KEsc [])) = B.continue $ s{taskEdit=Nothing} --- Exit the editor (keeping all changes) -updateTaskList s@UIState{taskEdit=Just _} (B.VtyEvent (VTY.EvKey VTY.KEnter [])) = B.continue $ finishEdit s --- Update the editor -updateTaskList s@UIState{taskEdit=Just edit} (B.VtyEvent e) = do - newTaskEdit <- updateEditor edit e - B.continue s{taskEdit=Just newTaskEdit} --- Catch everything else -updateTaskList s _ = B.halt s ---updateTaskList list (Just editor) (B.VtyEvent e) = (,) <$> const list <*> B.handleEditorEvent e editor diff --git a/src/TaskMachine/UI/TopBar.hs b/src/TaskMachine/UI/TopBar.hs deleted file mode 100644 index 16c708f..0000000 --- a/src/TaskMachine/UI/TopBar.hs +++ /dev/null @@ -1,6 +0,0 @@ -module TaskMachine.UI.TopBar where - -import qualified Brick as B - -placeholderTopBar :: B.Widget n -placeholderTopBar = B.str "Prune | Reload | Search: " B.<+> B.vLimit 1 (B.fill '_') diff --git a/src/TaskMachine/UI/Types.hs b/src/TaskMachine/UI/Types.hs deleted file mode 100644 index 4256d23..0000000 --- a/src/TaskMachine/UI/Types.hs +++ /dev/null @@ -1,151 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | A collection of types necessary for the UI. --- --- These were put in a separate module to avoid an import cycle. - -module TaskMachine.UI.Types - ( RName(..) - , BigRing(..) - , SmallRing(..) - -- * Popups - , Popup - , popup - , renderPopup - , handlePopupEvent - -- * UI state - , UIState(..) - , startUIState - , bigFocusNext, bigFocusPrev - , smallFocusNext, smallFocusPrev - , defaultTheme - ) where - -import qualified Brick as B -import qualified Brick.Focus as B -import qualified Brick.Themes as B -import qualified Brick.Widgets.Dialog as B -import qualified Brick.Widgets.Edit as B -import qualified Brick.Widgets.List as B -import qualified Data.Vector as V -import qualified Graphics.Vty as VTY - -import TaskMachine.LTask - --- | Resource names -data RName - = RSearchEdit - | RTaskList - | RTaskEdit - | RNewEdit - deriving (Eq, Show, Ord) - -data BigRing - = BRTopBar - | BRTaskList - | BRNewTask - deriving (Eq) - -data SmallRing - = SRPrune - | SRReload - | SRSearch - deriving (Eq) - -{- Popup -} - -data Popup = Popup (B.Dialog ()) (B.Widget RName) - -popup :: String -> String -> Popup -popup title content = - let dialog = B.dialog (Just title) (Just (0,[("OK",())])) 70 -- with a min terminal width of 80 - widget = B.str content - in Popup dialog widget - -renderPopup :: Popup -> B.Widget RName -renderPopup (Popup dialog widget) = B.renderDialog dialog widget - -handlePopupEvent :: VTY.Event -> Popup -> B.EventM RName Popup -handlePopupEvent e (Popup dialog widget) = Popup <$> B.handleDialogEvent e dialog <*> pure widget - -{- UI state -} - --- | The state of the program and UI -data UIState = UIState - { focus :: B.FocusRing BigRing - -- ^ 'B.FocusRing' for tab navigation - , focusTopBar :: B.FocusRing SmallRing - -- ^ 'B.FocusRing' for the top bar, for ← and → arrow key navigation - , errorPopup :: Maybe Popup - - -- TOP BAR - , searchEdit :: B.Editor String RName - -- ^ Content of the search field - - -- TASK LIST - , taskList :: B.List RName LTask - -- ^ List to display tasks - , invisibleTasks :: V.Vector LTask - -- ^ All tasks that aren't displayed in the taskList due to search filters - , taskEdit :: Maybe (B.Editor String RName) - -- ^ Task currently being edited - - -- NEW TASK - , newEdit :: B.Editor String RName - -- ^ "New task" text field at the bottom - } - --- | Create a starting UI state -startUIState :: V.Vector LTask -> UIState -startUIState ltasks = UIState - { focus = B.focusRing [BRTaskList, BRNewTask, BRTopBar] - , focusTopBar = B.focusRing [SRPrune, SRReload, SRSearch] - , errorPopup = Nothing - , searchEdit = B.editor RSearchEdit (Just 1) "" - , taskList = B.list RTaskList ltasks 1 - , invisibleTasks = V.empty - , taskEdit = Nothing - , newEdit = B.editor RNewEdit (Just 1) "" - } - -bigFocusNext :: UIState -> UIState -bigFocusNext s = s{focus=B.focusNext (focus s)} - -bigFocusPrev :: UIState -> UIState -bigFocusPrev s = s{focus=B.focusPrev (focus s)} - -smallFocusNext :: UIState -> UIState -smallFocusNext s = s{focusTopBar=B.focusNext (focusTopBar s)} - -smallFocusPrev :: UIState -> UIState -smallFocusPrev s = s{focusTopBar=B.focusPrev (focusTopBar s)} - -defaultTheme :: B.Theme -defaultTheme = B.newTheme VTY.defAttr - [ (B.dialogAttr, none) - , (B.buttonAttr, none) - , (B.buttonSelectedAttr, bg' VTY.blue) - , (B.editAttr, none) - , (B.editFocusedAttr, bg' VTY.blue) - , (B.listAttr, none) - , (B.listSelectedAttr, st' VTY.bold) - , (B.listSelectedFocusedAttr, bg VTY.blue $ st' VTY.bold) - , ("normal" , none) - , ("normal" <> "priority", fg VTY.cyan $ st' VTY.bold) - , ("normal" <> "priority" <> "A", fg VTY.red $ st' VTY.bold) - , ("normal" <> "priority" <> "B", fg VTY.yellow $ st' VTY.bold) - , ("normal" <> "priority" <> "C", fg VTY.green $ st' VTY.bold) - , ("highlight", bg' VTY.blue) - , ("highlight" <> "priority", bg VTY.blue $ fg VTY.cyan $ st' VTY.bold) - , ("highlight" <> "priority" <> "A", bg VTY.blue $ fg VTY.red $ st' VTY.bold) - , ("highlight" <> "priority" <> "B", bg VTY.blue $ fg VTY.yellow $ st' VTY.bold) - , ("highlight" <> "priority" <> "C", bg VTY.blue $ fg VTY.green $ st' VTY.bold) - ] - where - fg = flip VTY.withForeColor - bg = flip VTY.withBackColor - --st = flip VTY.withStyle - --fg' = VTY.withForeColor none - bg' = VTY.withBackColor none - st' = VTY.withStyle none - none = VTY.defAttr