Start work on the UI
This commit is contained in:
Joscha
parent
ef4a519e19
commit
223905301f
6 changed files with 280 additions and 30 deletions
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
138
src/TaskMachine/UI/Colortest.hs
Normal file
138
src/TaskMachine/UI/Colortest.hs
Normal file
|
|
@ -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
|
||||
}
|
||||
30
src/TaskMachine/UI/TaskList.hs
Normal file
30
src/TaskMachine/UI/TaskList.hs
Normal file
|
|
@ -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]
|
||||
77
src/TaskMachine/UI/Types.hs
Normal file
77
src/TaskMachine/UI/Types.hs
Normal file
|
|
@ -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
|
||||
Loading…
Add table
Add a link
Reference in a new issue