Start work on the UI

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.LTask
-import           TaskMachine.Todotxt
 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 -> void $ B.defaultMain (myApp defaultTheme) (startUIState tasks)
-    Right tasks -> mapM_ (print . ltaskTask) tasks

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

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                   as B
-import qualified Brick.AttrMap        as B
+import qualified Brick.Themes             as B
-import qualified Brick.Widgets.List   as B
+import qualified Brick.Widgets.Core      as B
-import qualified Data.Vector          as V
+import qualified Brick.Widgets.List      as B
-import qualified Graphics.Vty         as VTY
+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
+drawUIState :: UIState -> [B.Widget RName]
-  deriving (Eq, Ord)
+drawUIState UIState{..} = [B.renderList renderLTask True taskList]
 
-data UIState = UIState
+myApp :: B.Theme -> B.App UIState () RName
-  { taskList       :: B.List RName LTask
+myApp theme = B.App
-  , invisibleTasks :: V.Vector LTask
+  { B.appDraw         = drawUIState
-  }
-
-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 []
   , 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

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
+      }

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]

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