Use own task format
This commit is contained in:
Joscha
parent
ea87567455
commit
6fd0814057
12 changed files with 260 additions and 749 deletions
|
|
@ -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"
|
||||
|
|
|
|||
2
format.txt
Normal file
2
format.txt
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
-[ <priority>][ d<due date>][ c<creation date>] <description>
|
||||
x[<completion date>][ <priority>][ d<due date>][ c<creation date>] <description>
|
||||
30
package.yaml
30
package.yaml
|
|
@ -21,27 +21,27 @@ description: Please see the README on Github at <https://github.com/Garm
|
|||
|
||||
dependencies:
|
||||
- base >= 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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
238
src/TaskMachine/Task.hs
Normal file
238
src/TaskMachine/Task.hs
Normal file
|
|
@ -0,0 +1,238 @@
|
|||
-- | Read, parse and write tasks in a human-readable format
|
||||
--
|
||||
-- The format used by this module is inspired by the
|
||||
-- <https://github.com/todotxt/todo.txt/blob/master/README.md todo.txt format>
|
||||
-- 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
|
||||
|
|
@ -1,158 +0,0 @@
|
|||
-- | Read, parse and write tasks in the <https://github.com/todotxt/todo.txt todo.txt> 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'))
|
||||
|
|
@ -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")
|
||||
|
|
@ -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
|
||||
}
|
||||
|
|
@ -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 '_')
|
||||
|
|
@ -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
|
||||
|
|
@ -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 '_')
|
||||
|
|
@ -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
|
||||
Loading…
Add table
Add a link
Reference in a new issue