From 223905301f95bc373b7a8469d1da9e2ff20192c8 Mon Sep 17 00:00:00 2001 From: Joscha Date: Wed, 12 Sep 2018 19:57:14 +0000 Subject: [PATCH] Start work on the UI --- app/Main.hs | 7 +- src/TaskMachine/{TaskList.hs => LTask.hs} | 15 ++- src/TaskMachine/UI.hs | 43 +++---- src/TaskMachine/UI/Colortest.hs | 138 ++++++++++++++++++++++ src/TaskMachine/UI/TaskList.hs | 30 +++++ src/TaskMachine/UI/Types.hs | 77 ++++++++++++ 6 files changed, 280 insertions(+), 30 deletions(-) rename src/TaskMachine/{TaskList.hs => LTask.hs} (67%) create mode 100644 src/TaskMachine/UI/Colortest.hs create mode 100644 src/TaskMachine/UI/TaskList.hs create mode 100644 src/TaskMachine/UI/Types.hs diff --git a/app/Main.hs b/app/Main.hs index f9ff04b..e787a4b 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -6,9 +6,9 @@ import Control.Monad import qualified Brick as B import qualified Options.Applicative as O -import TaskMachine.TaskList -import TaskMachine.Todotxt +import TaskMachine.LTask import TaskMachine.UI +import TaskMachine.UI.Types data Options = Options { oTodofile :: FilePath @@ -36,5 +36,4 @@ main = do result <- loadLTasks (oTodofile o) case result of Left parseError -> putStrLn parseError - --Right tasks -> mapM_ (putStrLn . formatTask . ltaskTask) tasks - Right tasks -> mapM_ (print . ltaskTask) tasks + Right tasks -> void $ B.defaultMain (myApp defaultTheme) (startUIState tasks) diff --git a/src/TaskMachine/TaskList.hs b/src/TaskMachine/LTask.hs similarity index 67% rename from src/TaskMachine/TaskList.hs rename to src/TaskMachine/LTask.hs index 0a60918..7f07e23 100644 --- a/src/TaskMachine/TaskList.hs +++ b/src/TaskMachine/LTask.hs @@ -1,16 +1,21 @@ --- | A way to store the 'Task's that preserves the original task order +-- | A way to store the 'Task's that preserves the original task order. -module TaskMachine.TaskList +module TaskMachine.LTask ( LTask(..) , fromTasks , loadLTasks + , saveLTasks ) where +import Data.List +import Data.Function + import qualified Data.Vector as V import Text.Megaparsec 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 @@ -27,3 +32,9 @@ loadLTasks file = do case parseTasks file content of Right tasks -> pure $ Right $ V.fromList $ fromTasks tasks Left parseError -> pure $ Left $ show parseError + +saveLTasks :: V.Vector LTask -> FilePath -> IO () +saveLTasks ltasks file = do + let tasks = map ltaskTask $ sortBy (compare `on` ltaskNumber) $ V.toList ltasks + text = unlines $ map formatTask tasks + writeFile file text diff --git a/src/TaskMachine/UI.hs b/src/TaskMachine/UI.hs index 6f3eaa4..c8aaea8 100644 --- a/src/TaskMachine/UI.hs +++ b/src/TaskMachine/UI.hs @@ -1,16 +1,20 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module TaskMachine.UI where --import Data.Monoid -- -import qualified Brick as B -import qualified Brick.AttrMap as B -import qualified Brick.Widgets.List as B -import qualified Data.Vector as V -import qualified Graphics.Vty as VTY +import qualified Brick as B +import qualified Brick.Themes as B +import qualified Brick.Widgets.Core as B +import qualified Brick.Widgets.List as B +import qualified Data.Vector as V +import qualified Graphics.Vty as VTY -import TaskMachine.TaskList +import TaskMachine.LTask +import TaskMachine.Todotxt +import TaskMachine.UI.TaskList +import TaskMachine.UI.Types --import qualified Database.SQLite.Simple as DB --import qualified Brick.Themes as B -- @@ -44,28 +48,19 @@ Edit _____________________________ -- * warn if file only readable -- [_] display loaded tasks in UI -data RName = RTaskList - deriving (Eq, Ord) +drawUIState :: UIState -> [B.Widget RName] +drawUIState UIState{..} = [B.renderList renderLTask True taskList] -data UIState = UIState - { taskList :: B.List RName LTask - , invisibleTasks :: V.Vector LTask - } - -startUIState :: V.Vector LTask -> UIState -startUIState = undefined - -startState :: UIState -startState = UIState (B.list RTaskList V.empty 1) V.empty - -myApp :: B.App UIState () RName -myApp = B.App - { B.appDraw = const [] +myApp :: B.Theme -> B.App UIState () RName +myApp theme = B.App + { B.appDraw = drawUIState , B.appChooseCursor = B.neverShowCursor , B.appHandleEvent = B.resizeOrQuit , B.appStartEvent = pure - , B.appAttrMap = const $ B.attrMap VTY.defAttr [] + , B.appAttrMap = const $ attrMap } + where + attrMap = B.themeToAttrMap theme -- { uiConfig :: TM.Config -- , uiDBConnection :: DB.Connection diff --git a/src/TaskMachine/UI/Colortest.hs b/src/TaskMachine/UI/Colortest.hs new file mode 100644 index 0000000..84ad5a6 --- /dev/null +++ b/src/TaskMachine/UI/Colortest.hs @@ -0,0 +1,138 @@ +{-# 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 Brick.Focus as B +import qualified Brick.Themes as B +import qualified Brick.Widgets.List as B +import qualified Data.Vector as V +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 styles = foldr (.) id $ map (flip VTY.withStyle) styles + +attrMap :: B.AttrMap +attrMap = B.attrMap VTY.defAttr $ do + (fgName, fgColor) <- colors + (bgName, bgColor) <- colors + styleList <- subsequences styles + let styleName = concat $ map 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.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/TaskList.hs b/src/TaskMachine/UI/TaskList.hs new file mode 100644 index 0000000..e13d92e --- /dev/null +++ b/src/TaskMachine/UI/TaskList.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} + +module TaskMachine.UI.TaskList where + +import qualified Brick as B + +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] diff --git a/src/TaskMachine/UI/Types.hs b/src/TaskMachine/UI/Types.hs new file mode 100644 index 0000000..d487dc3 --- /dev/null +++ b/src/TaskMachine/UI/Types.hs @@ -0,0 +1,77 @@ +{-# 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(..) + , UIState(..) + , startUIState + , defaultTheme + ) where + +import qualified Brick.Focus as B +import qualified Brick.Themes 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 + -- These can be tab-cycled through + = RTopBar + | RTaskList + | REdit + -- Items in the top bar that are selected with the ← and → arrow keys + | RPrune + | RReload + | RSearch + deriving (Eq, Show, Ord) + +-- | The state of the program and UI +data UIState = UIState + { focus :: B.FocusRing RName + -- ^ 'B.FocusRing' for tab navigation + , topBarFocus :: B.FocusRing RName + -- ^ 'B.FocusRing' for the top bar, for ← and → arrow key navigation + , 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 + } + +-- | Create a starting UI state +startUIState :: V.Vector LTask -> UIState +startUIState ltasks = UIState + { focus = B.focusRing [RTaskList, REdit, RTopBar] + , topBarFocus = B.focusRing [RPrune, RReload, RSearch] + , taskList = B.list RTaskList ltasks 1 + , invisibleTasks = V.empty + } + +defaultTheme :: B.Theme +defaultTheme = B.newTheme VTY.defAttr + [ ("normal" , none) + , ("normal" <> "description", 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" <> "description", 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