Use own task format

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"

format.txt

@@ -0,0 +1,2 @@
+-[ <priority>][ d<due date>][ c<creation date>] <description>
+x[<completion date>][ <priority>][ d<due date>][ c<creation date>] <description>

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
+  #- optparse-applicative
-- text-zipper
+  #- sqlite-simple
+  #- stm
+  #- text
+  #- text-zipper
 - time
-- vector
+  #- transformers
-- vty
+  #- unix
+  #- unordered-containers
+  #- vector
+  #- vty
 # tests
 - hspec
 - QuickCheck
-  #- ConfigFile
-  #- sqlite-simple
-  #- text
-  #- unix
-  #- unordered-containers
-  #- transformers
-  #- async
-  #- aeson
-  #- bytestring
-  #- stm
 
 library:
   source-dirs: src

src/TaskMachine/LTask.hs

@@ -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

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

src/TaskMachine/Todotxt.hs

@@ -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'))

src/TaskMachine/UI.hs

@@ -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")

src/TaskMachine/UI/Colortest.hs

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

src/TaskMachine/UI/NewTask.hs

@@ -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 '_')

src/TaskMachine/UI/TaskList.hs

@@ -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

src/TaskMachine/UI/TopBar.hs

@@ -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 '_')

src/TaskMachine/UI/Types.hs

@@ -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