diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-} module Main where @@ -14,7 +13,8 @@ main = do config <- setup next <- runReaderT load config + time <- getCurrentTime case next of Exit -> pure () Output text -> putStrLn text - Load path lists -> go config $ create path lists + Load path lists -> go config $ create time path lists diff --git a/src/App.hs b/src/App.hs --- a/src/App.hs +++ b/src/App.hs @@ -6,25 +6,28 @@ import ClassyPrelude +import Control.Concurrent (forkIO, threadDelay) + import Control.Lens ((^.)) import Brick -import Graphics.Vty (Mode (BracketedPaste), displayBounds, outputIface, setMode, - supportsMode) +import Brick.BChan (BChan, newBChan, writeBChan) +import Graphics.Vty (Mode (BracketedPaste), defaultConfig, displayBounds, mkVty, + outputIface, setMode, supportsMode) import Graphics.Vty.Input.Events (Event (..)) import qualified Control.FoldDebounce as Debounce -import Data.Taskell.Date (currentDay) import Data.Taskell.Lists (Lists) import Events.Actions (ActionSets, event, generateActions) -import Events.State (continue, countCurrent, setHeight) +import Events.State (continue, countCurrent, setHeight, setTime) import Events.State.Types (State, current, io, lists, mode, path, searchTerm) import Events.State.Types.Mode (InsertMode (..), InsertType (..), ModalType (..), Mode (..)) -import IO.Config (Config, generateAttrMap, getBindings, layout) +import IO.Config (Config, debugging, generateAttrMap, getBindings, layout) import IO.Taskell (writeData) +import Types (ListIndex (..), TaskIndex (..)) import UI.Draw (chooseCursor, draw) -import UI.Types (ListIndex (..), ResourceName (..), TaskIndex (..)) +import UI.Types (ResourceName (..)) type DebouncedMessage = (Lists, FilePath) @@ -32,6 +35,22 @@ type Trigger = Debounce.Trigger DebouncedMessage DebouncedMessage +-- tick +data TaskellEvent = + Tick + +oneSecond :: Int +oneSecond = 1000000 + +frequency :: Int +frequency = 60 * oneSecond + +timer :: BChan TaskellEvent -> IO () +timer chan = + void . forkIO . forever $ do + writeBChan chan Tick + threadDelay frequency + -- store store :: Config -> DebouncedMessage -> IO () store config (ls, pth) = writeData config ls pth @@ -62,7 +81,7 @@ -- cache clearing clearCache :: State -> EventM ResourceName () clearCache state = do - let (li, ti) = state ^. current + let (ListIndex li, TaskIndex ti) = state ^. current invalidateCacheEntry (RNList li) invalidateCacheEntry (RNTask (ListIndex li, TaskIndex ti)) @@ -75,12 +94,20 @@ clearList :: State -> EventM ResourceName () clearList state = do - let (list, _) = state ^. current + let (ListIndex list, _) = state ^. current let count = countCurrent state let range = [0 .. (count - 1)] invalidateCacheEntry $ RNList list traverse_ (invalidateCacheEntry . RNTask . (,) (ListIndex list) . TaskIndex) range +clearDue :: State -> EventM ResourceName () +clearDue state = + case state ^. mode of + Modal (Due dues _) -> do + let range = [0 .. (length dues + 1)] + traverse_ (invalidateCacheEntry . RNDue) range + _ -> pure () + -- event handling handleVtyEvent :: (DebouncedWrite, Trigger) -> ActionSets -> State -> Event -> EventM ResourceName (Next State) @@ -93,6 +120,7 @@ _ -> pure () case state ^. mode of Shutdown -> liftIO (Debounce.close trigger) *> Brick.halt state + (Modal Due {}) -> clearDue state *> next send state (Modal MoveTo) -> clearAllTitles state *> next send state (Insert ITask ICreate _) -> clearList state *> next send state _ -> clearCache previousState *> clearCache state *> next send state @@ -104,8 +132,11 @@ (DebouncedWrite, Trigger) -> ActionSets -> State - -> BrickEvent ResourceName e + -> BrickEvent ResourceName TaskellEvent -> EventM ResourceName (Next State) +handleEvent _ _ state (AppEvent Tick) = do + t <- liftIO getCurrentTime + Brick.continue $ setTime t state handleEvent _ _ state (VtyEvent (EvResize _ _)) = do invalidateCache h <- getHeight @@ -126,15 +157,23 @@ go :: Config -> State -> IO () go config initial = do attrMap' <- const <$> generateAttrMap - today <- currentDay + -- setup debouncing db <- debounce config initial + -- get bindings bindings <- getBindings + -- setup timer channel + timerChan <- newBChan 1 + timer timerChan + -- create app let app = App - { appDraw = draw (layout config) bindings today + { appDraw = draw (layout config) bindings (debugging config) , appChooseCursor = chooseCursor , appHandleEvent = handleEvent db (generateActions bindings) , appStartEvent = appStart , appAttrMap = attrMap' } - void (defaultMain app initial) + -- start + let builder = mkVty defaultConfig + initialVty <- builder + void $ customMain initialVty builder (Just timerChan) app initial diff --git a/src/Config.hs b/src/Config.hs --- a/src/Config.hs +++ b/src/Config.hs @@ -9,7 +9,7 @@ import Data.FileEmbed (embedFile) version :: Text -version = "1.5.0" +version = "1.7.0" usage :: Text usage = decodeUtf8 $(embedFile "templates/usage.txt") diff --git a/src/Data/Taskell/Date.hs b/src/Data/Taskell/Date.hs --- a/src/Data/Taskell/Date.hs +++ b/src/Data/Taskell/Date.hs @@ -9,7 +9,6 @@ , dayToOutput , textToDay , utcToLocalDay - , currentDay , deadline ) where @@ -52,9 +51,6 @@ textToDay :: Text -> Maybe Day textToDay = (utctDay <$>) . textToTime - -currentDay :: IO Day -currentDay = utctDay <$> getCurrentTime -- work out the deadline deadline :: Day -> Day -> Deadline diff --git a/src/Data/Taskell/List.hs b/src/Data/Taskell/List.hs --- a/src/Data/Taskell/List.hs +++ b/src/Data/Taskell/List.hs @@ -2,13 +2,17 @@ module Data.Taskell.List ( List + , Update , title , tasks , create , empty + , due + , clearDue , new , count , newAt + , duplicate , append , extract , updateFn diff --git a/src/Data/Taskell/List/Internal.hs b/src/Data/Taskell/List/Internal.hs --- a/src/Data/Taskell/List/Internal.hs +++ b/src/Data/Taskell/List/Internal.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} module Data.Taskell.List.Internal where @@ -10,7 +11,8 @@ import Data.Sequence as S (adjust', deleteAt, insertAt, update, (|>)) import qualified Data.Taskell.Seq as S -import qualified Data.Taskell.Task as T (Task, Update, blank, contains) +import qualified Data.Taskell.Task as T (Task, Update, blank, clearDue, contains, due, duplicate) +import Types (TaskIndex (TaskIndex)) data List = List { _title :: Text @@ -35,9 +37,22 @@ count :: List -> Int count = length . (^. tasks) +due :: List -> Seq (TaskIndex, T.Task) +due list = catMaybes (filt S.<#> (list ^. tasks)) + where + filt int task = const (TaskIndex int, task) <$> task ^. T.due + +clearDue :: TaskIndex -> Update +clearDue (TaskIndex int) = updateFn int T.clearDue + newAt :: Int -> Update -newAt idx = tasks %~ insertAt idx T.blank +newAt idx = tasks %~ S.insertAt idx T.blank +duplicate :: Int -> List -> Maybe List +duplicate idx list = do + task <- T.duplicate <$> getTask idx list + pure $ list & tasks %~ S.insertAt idx task + append :: T.Task -> Update append task = tasks %~ (|> task) @@ -52,8 +67,13 @@ update :: Int -> T.Task -> Update update idx task = tasks %~ S.update idx task -move :: Int -> Int -> List -> Maybe List -move from dir = tasks %%~ S.shiftBy from dir +move :: Int -> Int -> Maybe Text -> List -> Maybe (List, Int) +move current dir term list = + case term of + Nothing -> (, bound list (current + dir)) <$> (list & tasks %%~ S.shiftBy current dir) + Just _ -> do + idx <- changeTask dir current term list + (, idx) <$> (list & tasks %%~ S.shiftBy current (idx - current)) deleteTask :: Int -> Update deleteTask idx = tasks %~ deleteAt idx @@ -87,11 +107,8 @@ then next else previous -bound :: Int -> List -> Int -bound idx lst - | idx < 0 = 0 - | idx > count lst = count lst - 1 - | otherwise = idx +bound :: List -> Int -> Int +bound lst = S.bound (lst ^. tasks) nearest' :: Int -> Maybe Text -> List -> Maybe Int nearest' current term lst = do @@ -106,5 +123,5 @@ near = fromMaybe (-1) $ nearest' current term lst idx = case term of - Nothing -> bound current lst + Nothing -> bound lst current Just txt -> maybe near (bool near current . T.contains txt) $ getTask current lst diff --git a/src/Data/Taskell/Lists.hs b/src/Data/Taskell/Lists.hs --- a/src/Data/Taskell/Lists.hs +++ b/src/Data/Taskell/Lists.hs @@ -5,6 +5,8 @@ , initial , updateLists , count + , due + , clearDue , get , changeList , newList diff --git a/src/Data/Taskell/Lists/Internal.hs b/src/Data/Taskell/Lists/Internal.hs --- a/src/Data/Taskell/Lists/Internal.hs +++ b/src/Data/Taskell/Lists/Internal.hs @@ -1,41 +1,57 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} module Data.Taskell.Lists.Internal where -import ClassyPrelude hiding (empty) +import ClassyPrelude -import Data.Sequence as S (deleteAt, update, (!?), (|>)) +import Control.Lens ((^.)) +import Data.Sequence as S (adjust', deleteAt, update, (!?), (|>)) -import Data.Taskell.List as L (List, append, count, empty, extract, searchFor) +import qualified Data.Taskell.List as L (List, Update, append, clearDue, count, due, empty, extract, + searchFor) import qualified Data.Taskell.Seq as S -import Data.Taskell.Task (Task) +import qualified Data.Taskell.Task as T (Task, due) +import Types (ListIndex (ListIndex), Pointer, TaskIndex (TaskIndex)) -type Lists = Seq List +type Lists = Seq L.List type Update = Lists -> Lists initial :: Lists -initial = fromList [empty "To Do", empty "Done"] +initial = fromList [L.empty "To Do", L.empty "Done"] -updateLists :: Int -> List -> Update +updateLists :: Int -> L.List -> Update updateLists = S.update count :: Int -> Lists -> Int count idx tasks = maybe 0 L.count (tasks !? idx) -get :: Lists -> Int -> Maybe List +due :: Lists -> Seq (Pointer, T.Task) +due lists = sortOn ((^. T.due) . snd) dues + where + format x lst = (\(y, t) -> ((ListIndex x, y), t)) <$> L.due lst + dues = concat $ format S.<#> lists + +clearDue :: Pointer -> Update +clearDue (idx, tsk) = updateFn idx (L.clearDue tsk) + +updateFn :: ListIndex -> L.Update -> Update +updateFn (ListIndex idx) fn = adjust' fn idx + +get :: Lists -> Int -> Maybe L.List get = (!?) -changeList :: (Int, Int) -> Lists -> Int -> Maybe Lists -changeList (list, idx) tasks dir = do +changeList :: Pointer -> Lists -> Int -> Maybe Lists +changeList (ListIndex list, TaskIndex idx) tasks dir = do let next = list + dir - (from, task) <- extract idx =<< tasks !? list -- extract current task - to <- append task <$> tasks !? next -- get next list and append task + (from, task) <- L.extract idx =<< tasks !? list -- extract current task + to <- L.append task <$> tasks !? next -- get next list and append task pure . updateLists next to $ updateLists list from tasks -- update lists newList :: Text -> Update -newList title = (|> empty title) +newList title = (|> L.empty title) delete :: Int -> Update delete = deleteAt @@ -47,13 +63,13 @@ shiftBy = S.shiftBy search :: Text -> Update -search text = (searchFor text <$>) +search text = (L.searchFor text <$>) -appendToLast :: Task -> Update +appendToLast :: T.Task -> Update appendToLast task lists = fromMaybe lists $ do let idx = length lists - 1 - list <- append task <$> lists !? idx + list <- L.append task <$> lists !? idx pure $ updateLists idx list lists analyse :: Text -> Lists -> Text diff --git a/src/Data/Taskell/Seq.hs b/src/Data/Taskell/Seq.hs --- a/src/Data/Taskell/Seq.hs +++ b/src/Data/Taskell/Seq.hs @@ -4,8 +4,11 @@ import ClassyPrelude -import Data.Sequence (deleteAt, insertAt, (!?)) +import Data.Sequence (deleteAt, insertAt, mapWithIndex, (!?)) +(<#>) :: (Int -> a -> b) -> Seq a -> Seq b +(<#>) = mapWithIndex + extract :: Int -> Seq a -> Maybe (Seq a, a) extract idx xs = (,) (deleteAt idx xs) <$> xs !? idx @@ -13,3 +16,9 @@ shiftBy idx dir xs = do (a, current) <- extract idx xs pure $ insertAt (idx + dir) current a + +bound :: Seq a -> Int -> Int +bound s i + | i < 0 = 0 + | i >= length s = pred (length s) + | otherwise = i diff --git a/src/Data/Taskell/Subtask.hs b/src/Data/Taskell/Subtask.hs --- a/src/Data/Taskell/Subtask.hs +++ b/src/Data/Taskell/Subtask.hs @@ -8,6 +8,7 @@ , name , complete , toggle + , duplicate ) where import Data.Taskell.Subtask.Internal diff --git a/src/Data/Taskell/Subtask/Internal.hs b/src/Data/Taskell/Subtask/Internal.hs --- a/src/Data/Taskell/Subtask/Internal.hs +++ b/src/Data/Taskell/Subtask/Internal.hs @@ -26,3 +26,6 @@ toggle :: Update toggle = complete %~ not + +duplicate :: Subtask -> Subtask +duplicate (Subtask n c) = Subtask n c diff --git a/src/Data/Taskell/Task.hs b/src/Data/Taskell/Task.hs --- a/src/Data/Taskell/Task.hs +++ b/src/Data/Taskell/Task.hs @@ -9,9 +9,11 @@ , subtasks , blank , new + , duplicate , setDescription , appendDescription , setDue + , clearDue , getSubtask , addSubtask , hasSubtasks diff --git a/src/Data/Taskell/Task/Internal.hs b/src/Data/Taskell/Task/Internal.hs --- a/src/Data/Taskell/Task/Internal.hs +++ b/src/Data/Taskell/Task/Internal.hs @@ -10,7 +10,7 @@ import Data.Sequence as S (adjust', deleteAt, (|>)) import Data.Taskell.Date (Day, textToDay) -import qualified Data.Taskell.Subtask as ST (Subtask, Update, complete, name) +import qualified Data.Taskell.Subtask as ST (Subtask, Update, complete, duplicate, name) import Data.Text (strip) data Task = Task @@ -57,6 +57,9 @@ Just day -> task & due .~ Just day Nothing -> task +clearDue :: Update +clearDue task = task & due .~ Nothing + getSubtask :: Int -> Task -> Maybe ST.Subtask getSubtask idx = (^? subtasks . ix idx) @@ -89,3 +92,6 @@ isBlank task = null (task ^. name) && isNothing (task ^. description) && null (task ^. subtasks) && isNothing (task ^. due) + +duplicate :: Task -> Task +duplicate (Task n d st du) = Task n d (ST.duplicate <$> st) du diff --git a/src/Events/Actions.hs b/src/Events/Actions.hs --- a/src/Events/Actions.hs +++ b/src/Events/Actions.hs @@ -21,6 +21,7 @@ import qualified Events.Actions.Insert as Insert import qualified Events.Actions.Modal as Modal import qualified Events.Actions.Modal.Detail as Detail +import qualified Events.Actions.Modal.Due as Due import qualified Events.Actions.Modal.Help as Help import qualified Events.Actions.Normal as Normal import qualified Events.Actions.Search as Search @@ -43,6 +44,7 @@ case state ^. mode of Normal -> lookup e $ normal actions Modal (Detail _ DetailNormal) -> lookup e $ detail actions + Modal Due {} -> lookup e $ due actions Modal Help -> lookup e $ help actions _ -> Nothing fromMaybe state $ @@ -54,6 +56,7 @@ { normal :: BoundActions , detail :: BoundActions , help :: BoundActions + , due :: BoundActions } generateActions :: Bindings -> ActionSets @@ -62,4 +65,5 @@ { normal = generate bindings Normal.events , detail = generate bindings Detail.events , help = generate bindings Help.events + , due = generate bindings Due.events } diff --git a/src/Events/Actions/Insert.hs b/src/Events/Actions/Insert.hs --- a/src/Events/Actions/Insert.hs +++ b/src/Events/Actions/Insert.hs @@ -12,7 +12,7 @@ import Events.State.Types import Events.State.Types.Mode (InsertMode (..), InsertType (..), Mode (Insert)) import Graphics.Vty.Input.Events (Event (EvKey), Key (KEnter, KEsc)) -import qualified UI.Field as F (event) +import qualified UI.Draw.Field as F (event) event :: Event -> Stateful event (EvKey KEnter _) state = diff --git a/src/Events/Actions/Modal.hs b/src/Events/Actions/Modal.hs --- a/src/Events/Actions/Modal.hs +++ b/src/Events/Actions/Modal.hs @@ -13,13 +13,15 @@ import Graphics.Vty.Input.Events import qualified Events.Actions.Modal.Detail as Detail +import qualified Events.Actions.Modal.Due as Due import qualified Events.Actions.Modal.Help as Help import qualified Events.Actions.Modal.MoveTo as MoveTo event :: Event -> Stateful event e s = case s ^. mode of - Modal Help -> Help.event e s - Modal (Detail _ _) -> Detail.event e s - Modal MoveTo -> MoveTo.event e s - _ -> pure s + Modal Help -> Help.event e s + Modal Detail {} -> Detail.event e s + Modal MoveTo -> MoveTo.event e s + Modal Due {} -> Due.event e s + _ -> pure s diff --git a/src/Events/Actions/Modal/Detail.hs b/src/Events/Actions/Modal/Detail.hs --- a/src/Events/Actions/Modal/Detail.hs +++ b/src/Events/Actions/Modal/Detail.hs @@ -16,7 +16,7 @@ import Events.State.Types.Mode (DetailItem (..), DetailMode (..)) import Graphics.Vty.Input.Events import IO.Keyboard.Types (Actions) -import qualified UI.Field as F (event) +import qualified UI.Draw.Field as F (event) events :: Actions events @@ -28,9 +28,10 @@ , (A.Next, nextSubtask) , (A.New, (Detail.insertMode =<<) . (Detail.lastSubtask =<<) . (Detail.newItem =<<) . store) , (A.Edit, (Detail.insertMode =<<) . store) - , (A.MoveRight, (write =<<) . (setComplete =<<) . store) + , (A.Complete, (write =<<) . (setComplete =<<) . store) , (A.Delete, (write =<<) . (Detail.remove =<<) . store) , (A.DueDate, (editDue =<<) . store) + , (A.ClearDate, (write =<<) . (clearDate =<<) . store) , (A.Detail, (editDescription =<<) . store) ] diff --git a/src/Events/Actions/Modal/Due.hs b/src/Events/Actions/Modal/Due.hs new file mode 100644 --- /dev/null +++ b/src/Events/Actions/Modal/Due.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedLists #-} + +module Events.Actions.Modal.Due + ( event + , events + ) where + +import ClassyPrelude + +import Events.Actions.Types as A (ActionType (..)) +import Events.State (normalMode, store, write) +import Events.State.Modal.Detail (showDetail) +import Events.State.Modal.Due (clearDate, goto, next, previous) +import Events.State.Types (Stateful) +import Graphics.Vty.Input.Events (Event (EvKey)) +import IO.Keyboard.Types (Actions) + +events :: Actions +events = + [ (A.Previous, previous) + , (A.Next, next) + , (A.Detail, (showDetail =<<) . goto) + , (A.ClearDate, (write =<<) . (clearDate =<<) . store) + ] + +event :: Event -> Stateful +event (EvKey _ _) = normalMode +event _ = pure diff --git a/src/Events/Actions/Normal.hs b/src/Events/Actions/Normal.hs --- a/src/Events/Actions/Normal.hs +++ b/src/Events/Actions/Normal.hs @@ -12,6 +12,7 @@ import Events.Actions.Types as A (ActionType (..)) import Events.State import Events.State.Modal.Detail (editDue, showDetail) +import Events.State.Modal.Due (showDue) import Events.State.Types (Stateful) import Graphics.Vty.Input.Events import IO.Keyboard.Types (Actions) @@ -24,6 +25,7 @@ , (A.Undo, (write =<<) . undo) , (A.Search, searchMode) , (A.Help, showHelp) + , (A.Due, showDue) -- navigation , (A.Previous, previous) , (A.Next, next) @@ -34,17 +36,20 @@ , (A.New, (startCreate =<<) . (newItem =<<) . store) , (A.NewAbove, (startCreate =<<) . (above =<<) . store) , (A.NewBelow, (startCreate =<<) . (below =<<) . store) + , (A.Duplicate, (next =<<) . (write =<<) . (duplicate =<<) . store) -- editing tasks , (A.Edit, (startEdit =<<) . store) , (A.Clear, (startEdit =<<) . (clearItem =<<) . store) , (A.Delete, (write =<<) . (delete =<<) . store) , (A.Detail, showDetail) , (A.DueDate, (editDue =<<) . (store =<<) . showDetail) + , (A.ClearDate, (write =<<) . (clearDate =<<) . store) -- moving tasks , (A.MoveUp, (write =<<) . (up =<<) . store) , (A.MoveDown, (write =<<) . (down =<<) . store) , (A.MoveLeft, (write =<<) . (bottom =<<) . (left =<<) . (moveLeft =<<) . store) , (A.MoveRight, (write =<<) . (bottom =<<) . (right =<<) . (moveRight =<<) . store) + , (A.Complete, (write =<<) . (moveToLast =<<) . (clearDate =<<) . store) , (A.MoveMenu, showMoveTo) -- lists , (A.ListNew, (createListStart =<<) . store) diff --git a/src/Events/Actions/Search.hs b/src/Events/Actions/Search.hs --- a/src/Events/Actions/Search.hs +++ b/src/Events/Actions/Search.hs @@ -12,7 +12,7 @@ import Events.State.Types (Stateful, mode) import Events.State.Types.Mode (Mode (Search)) import Graphics.Vty.Input.Events -import qualified UI.Field as F (event) +import qualified UI.Draw.Field as F (event) event :: Event -> Stateful event (EvKey KEsc _) s = clearSearch =<< normalMode s diff --git a/src/Events/Actions/Types.hs b/src/Events/Actions/Types.hs --- a/src/Events/Actions/Types.hs +++ b/src/Events/Actions/Types.hs @@ -9,6 +9,7 @@ = Quit | Undo | Search + | Due | Help | Previous | Next @@ -18,15 +19,18 @@ | New | NewAbove | NewBelow + | Duplicate | Edit | Clear | Delete | Detail | DueDate + | ClearDate | MoveUp | MoveDown | MoveLeft | MoveRight + | Complete | MoveMenu | ListNew | ListEdit @@ -43,6 +47,7 @@ read "quit" = Quit read "undo" = Undo read "search" = Search +read "due" = Due read "help" = Help read "previous" = Previous read "next" = Next @@ -52,15 +57,18 @@ read "new" = New read "newAbove" = NewAbove read "newBelow" = NewBelow +read "duplicate" = Duplicate read "edit" = Edit read "clear" = Clear read "delete" = Delete read "detail" = Detail read "dueDate" = DueDate +read "clearDate" = ClearDate read "moveUp" = MoveUp read "moveDown" = MoveDown read "moveLeft" = MoveLeft read "moveRight" = MoveRight +read "complete" = Complete read "moveMenu" = MoveMenu read "listNew" = ListNew read "listEdit" = ListEdit diff --git a/src/Events/State.hs b/src/Events/State.hs --- a/src/Events/State.hs +++ b/src/Events/State.hs @@ -5,6 +5,7 @@ -- App ( continue , write + , setTime , countCurrent , setHeight -- UI.Main @@ -19,10 +20,12 @@ , editListStart , deleteCurrentList , clearItem + , clearDate , above , below , bottom , previous + , duplicate , next , left , right @@ -30,6 +33,7 @@ , down , moveLeft , moveRight + , moveToLast , delete , selectList , listLeft @@ -61,46 +65,51 @@ import Data.Char (digitToInt, ord) -import Data.Taskell.List (List, deleteTask, getTask, move, nearest, new, newAt, nextTask, - prevTask, title, update) +import qualified Data.Taskell.List as L (List, deleteTask, duplicate, getTask, move, nearest, new, + newAt, nextTask, prevTask, title, update) import qualified Data.Taskell.Lists as Lists import Data.Taskell.Task (Task, isBlank, name) +import Types import Events.State.Types import Events.State.Types.Mode (InsertMode (..), InsertType (..), ModalType (..), Mode (..)) -import UI.Field (Field, blankField, getText, textToField) +import UI.Draw.Field (Field, blankField, getText, textToField) type InternalStateful = State -> State -create :: FilePath -> Lists.Lists -> State -create p ls = +create :: UTCTime -> FilePath -> Lists.Lists -> State +create t p ls = State { _mode = Normal , _lists = ls , _history = [] - , _current = (0, 0) + , _current = (ListIndex 0, TaskIndex 0) , _path = p , _io = Nothing , _height = 0 , _searchTerm = Nothing + , _time = t } -- app state quit :: Stateful -quit = Just . (mode .~ Shutdown) +quit = pure . (mode .~ Shutdown) continue :: State -> State continue = io .~ Nothing +setTime :: UTCTime -> State -> State +setTime t = time .~ t + write :: Stateful -write state = Just $ state & io .~ Just (state ^. lists) +write state = pure $ state & io .~ Just (state ^. lists) store :: Stateful -store state = Just $ state & history .~ (state ^. current, state ^. lists) : state ^. history +store state = pure $ state & history .~ (state ^. current, state ^. lists) : state ^. history undo :: Stateful undo state = - Just $ + pure $ case state ^. history of [] -> state ((c, l):xs) -> state & current .~ c & lists .~ l & history .~ xs @@ -108,7 +117,7 @@ -- createList createList :: Stateful createList state = - Just $ + pure $ case state ^. mode of Insert IList ICreate f -> updateListToLast . setLists state $ Lists.newList (getText f) $ state ^. lists @@ -118,31 +127,31 @@ updateListToLast state = setCurrentList state (length (state ^. lists) - 1) createListStart :: Stateful -createListStart = Just . (mode .~ Insert IList ICreate blankField) +createListStart = pure . (mode .~ Insert IList ICreate blankField) -- editList editListStart :: Stateful editListStart state = do - f <- textToField . (^. title) <$> getList state + f <- textToField . (^. L.title) <$> getList state pure $ state & mode .~ Insert IList IEdit f deleteCurrentList :: Stateful deleteCurrentList state = - Just . fixIndex . setLists state $ Lists.delete (getCurrentList state) (state ^. lists) + pure . fixIndex . setLists state $ Lists.delete (getCurrentList state) (state ^. lists) -- insert getCurrentTask :: State -> Maybe Task -getCurrentTask state = getList state >>= getTask (getIndex state) +getCurrentTask state = getList state >>= L.getTask (getIndex state) setCurrentTask :: Task -> Stateful -setCurrentTask task state = setList state . update (getIndex state) task <$> getList state +setCurrentTask task state = setList state . L.update (getIndex state) task <$> getList state setCurrentTaskText :: Text -> Stateful setCurrentTaskText text state = flip setCurrentTask state =<< (name .~ text) <$> getCurrentTask state startCreate :: Stateful -startCreate = Just . (mode .~ Insert ITask ICreate blankField) +startCreate = pure . (mode .~ Insert ITask ICreate blankField) startEdit :: Stateful startEdit state = do @@ -154,22 +163,22 @@ case state ^. mode of Insert ITask iMode f -> setCurrentTaskText (getText f) $ state & (mode .~ Insert ITask iMode blankField) - _ -> Just state + _ -> pure state finishListTitle :: Stateful finishListTitle state = case state ^. mode of Insert IList iMode f -> setCurrentListTitle (getText f) $ state & (mode .~ Insert IList iMode blankField) - _ -> Just state + _ -> pure state normalMode :: Stateful -normalMode = Just . (mode .~ Normal) +normalMode = pure . (mode .~ Normal) addToListAt :: Int -> Stateful addToListAt offset state = do let idx = getIndex state + offset - fixIndex . setList (setIndex state idx) . newAt idx <$> getList state + fixIndex . setList (setIndex state idx) . L.newAt idx <$> getList state above :: Stateful above = addToListAt 0 @@ -178,11 +187,17 @@ below = addToListAt 1 newItem :: Stateful -newItem state = selectLast . setList state . new <$> getList state +newItem state = selectLast . setList state . L.new <$> getList state +duplicate :: Stateful +duplicate state = setList state <$> (L.duplicate (getIndex state) =<< getList state) + clearItem :: Stateful clearItem = setCurrentTaskText "" +clearDate :: Stateful +clearDate state = pure $ state & lists .~ Lists.clearDue (state ^. current) (state ^. lists) + bottom :: Stateful bottom = pure . selectLast @@ -198,27 +213,42 @@ state -- moving +-- +moveVertical :: Int -> Stateful +moveVertical dir state = do + (lst, idx) <- L.move (getIndex state) dir (getText <$> state ^. searchTerm) =<< getList state + pure $ setIndex (setList state lst) idx + up :: Stateful -up state = previous =<< setList state <$> (move (getIndex state) (-1) =<< getList state) +up = moveVertical (-1) down :: Stateful -down state = next =<< setList state <$> (move (getIndex state) 1 =<< getList state) +down = moveVertical 1 -move' :: Int -> State -> Maybe State -move' idx state = +moveHorizontal :: Int -> State -> Maybe State +moveHorizontal idx state = fixIndex . setLists state <$> Lists.changeList (state ^. current) (state ^. lists) idx moveLeft :: Stateful -moveLeft = move' (-1) +moveLeft = moveHorizontal (-1) moveRight :: Stateful -moveRight = move' 1 +moveRight = moveHorizontal 1 +moveToLast :: Stateful +moveToLast state = + if idx == cur + then pure state + else moveHorizontal (idx - cur) state + where + idx = length (state ^. lists) - 1 + cur = getCurrentList state + selectList :: Char -> Stateful selectList idx state = - Just $ + pure $ (if exists - then current .~ (list, 0) + then current .~ (ListIndex list, TaskIndex 0) else id) state where @@ -227,37 +257,37 @@ -- removing delete :: Stateful -delete state = fixIndex . setList state . deleteTask (getIndex state) <$> getList state +delete state = fixIndex . setList state . L.deleteTask (getIndex state) <$> getList state -- list and index countCurrent :: State -> Int countCurrent state = Lists.count (getCurrentList state) (state ^. lists) setIndex :: State -> Int -> State -setIndex state idx = state & current .~ (getCurrentList state, idx) +setIndex state idx = state & current .~ (ListIndex (getCurrentList state), TaskIndex idx) setCurrentList :: State -> Int -> State -setCurrentList state idx = state & current .~ (idx, getIndex state) +setCurrentList state idx = state & current .~ (ListIndex idx, TaskIndex (getIndex state)) getIndex :: State -> Int -getIndex = snd . (^. current) +getIndex = showTaskIndex . snd . (^. current) -changeTask :: (Int -> Maybe Text -> List -> Int) -> Stateful +changeTask :: (Int -> Maybe Text -> L.List -> Int) -> Stateful changeTask fn state = do list <- getList state let idx = getIndex state let term = getText <$> state ^. searchTerm - Just $ setIndex state (fn idx term list) + pure $ setIndex state (fn idx term list) next :: Stateful -next = changeTask nextTask +next = changeTask L.nextTask previous :: Stateful -previous = changeTask prevTask +previous = changeTask L.prevTask left :: Stateful left state = - Just . fixIndex . setCurrentList state $ + pure . fixIndex . setCurrentList state $ if list > 0 then pred list else 0 @@ -266,7 +296,7 @@ right :: Stateful right state = - Just . fixIndex . setCurrentList state $ + pure . fixIndex . setCurrentList state $ if list < (count - 1) then succ list else list @@ -274,41 +304,52 @@ list = getCurrentList state count = length (state ^. lists) +fixListIndex :: InternalStateful +fixListIndex state = + if listIdx + then state + else setCurrentList state (length lists' - 1) + where + lists' = state ^. lists + listIdx = Lists.exists (getCurrentList state) lists' + fixIndex :: InternalStateful fixIndex state = case getList state of - Just list -> setIndex state (nearest idx trm list) - Nothing -> state + Just list -> setIndex state (L.nearest idx trm list) + Nothing -> fixListIndex state where trm = getText <$> state ^. searchTerm idx = getIndex state -- tasks getCurrentList :: State -> Int -getCurrentList = fst . (^. current) +getCurrentList = showListIndex . fst . (^. current) -getList :: State -> Maybe List +getList :: State -> Maybe L.List getList state = Lists.get (state ^. lists) (getCurrentList state) -setList :: State -> List -> State +setList :: State -> L.List -> State setList state list = setLists state (Lists.updateLists (getCurrentList state) list (state ^. lists)) setCurrentListTitle :: Text -> Stateful -setCurrentListTitle text state = setList state . (title .~ text) <$> getList state +setCurrentListTitle text state = setList state . (L.title .~ text) <$> getList state setLists :: State -> Lists.Lists -> State setLists state lists' = state & lists .~ lists' -moveTo :: Char -> Stateful -moveTo char state = do - let li = ord char - ord 'a' - cur = getCurrentList state +moveTo' :: Int -> Stateful +moveTo' li state = do + let cur = getCurrentList state if li == cur || li < 0 || li >= length (state ^. lists) then Nothing else do - s <- move' (li - cur) state + s <- moveHorizontal (li - cur) state pure . selectLast $ setCurrentList s li +moveTo :: Char -> Stateful +moveTo char = moveTo' (ord char - ord 'a') + -- move lists listMove :: Int -> Stateful listMove offset state = do @@ -330,7 +371,7 @@ searchMode :: Stateful searchMode state = pure . fixIndex $ (state & mode .~ Search) & searchTerm .~ sTerm where - sTerm = Just (fromMaybe blankField (state ^. searchTerm)) + sTerm = pure (fromMaybe blankField (state ^. searchTerm)) clearSearch :: Stateful clearSearch state = pure $ state & searchTerm .~ Nothing @@ -338,18 +379,18 @@ appendSearch :: (Field -> Field) -> Stateful appendSearch genField state = do let field = fromMaybe blankField (state ^. searchTerm) - pure . fixIndex $ state & searchTerm .~ Just (genField field) + pure . fixIndex $ state & searchTerm .~ pure (genField field) -- help showHelp :: Stateful -showHelp = Just . (mode .~ Modal Help) +showHelp = pure . (mode .~ Modal Help) showMoveTo :: Stateful -showMoveTo = Just . (mode .~ Modal MoveTo) +showMoveTo state = const (state & mode .~ Modal MoveTo) <$> getCurrentTask state -- view setHeight :: Int -> State -> State -setHeight i = height .~ i +setHeight = (.~) height -- more view - maybe shouldn't be in here... newList :: State -> State diff --git a/src/Events/State/Modal/Detail.hs b/src/Events/State/Modal/Detail.hs --- a/src/Events/State/Modal/Detail.hs +++ b/src/Events/State/Modal/Detail.hs @@ -34,7 +34,7 @@ import Events.State.Types (State, Stateful, mode) import Events.State.Types.Mode (DetailItem (..), DetailMode (..), ModalType (Detail), Mode (Modal)) -import UI.Field (Field, blankField, getText, textToField) +import UI.Draw.Field (Field, blankField, getText, textToField) updateField :: (Field -> Field) -> Stateful updateField fieldEvent s = @@ -159,4 +159,4 @@ | i > lst = lst | i < 0 = 0 | otherwise = i - pure $ state & mode .~ Modal (Detail (DetailItem newIndex) m) + return $ state & mode .~ Modal (Detail (DetailItem newIndex) m) diff --git a/src/Events/State/Modal/Due.hs b/src/Events/State/Modal/Due.hs new file mode 100644 --- /dev/null +++ b/src/Events/State/Modal/Due.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Events.State.Modal.Due + ( showDue + , clearDate + , previous + , next + , goto + ) where + +import ClassyPrelude + +import Control.Lens ((&), (.~), (^.)) +import Data.Sequence ((!?)) + +import qualified Data.Taskell.Lists as L (clearDue, due) +import Data.Taskell.Seq (bound) +import Data.Taskell.Task (Task) +import Events.State.Types (Stateful, current, lists, mode) +import Events.State.Types.Mode (ModalType (Due), Mode (..)) +import Types (Pointer) + +type DueStateful = Seq (Pointer, Task) -> Int -> Stateful + +λfilter :: DueStateful -> Stateful +λfilter fn state = + case state ^. mode of + Modal (Due due cur) -> fn due cur state + _ -> pure state + +λsetMode :: DueStateful +λsetMode due pos state = pure $ state & mode .~ Modal (Due due pos) + +λprevious :: DueStateful +λprevious due cur = λsetMode due (bound due (cur - 1)) + +λnext :: DueStateful +λnext due cur = λsetMode due (bound due (cur + 1)) + +λgoto :: DueStateful +λgoto due cur state = + case due !? cur of + Just (pointer, _) -> pure $ state & current .~ pointer + Nothing -> Nothing + +λclearDate :: DueStateful +λclearDate due cur state = + case due !? cur of + Just (pointer, _) -> do + let new = L.clearDue pointer (state ^. lists) + let dues = L.due new + λsetMode dues (bound dues cur) (state & lists .~ new) + Nothing -> Nothing + +showDue :: Stateful +showDue state = λsetMode (L.due (state ^. lists)) 0 state + +previous :: Stateful +previous = λfilter λprevious + +next :: Stateful +next = λfilter λnext + +goto :: Stateful +goto = λfilter λgoto + +clearDate :: Stateful +clearDate = λfilter λclearDate diff --git a/src/Events/State/Types.hs b/src/Events/State/Types.hs --- a/src/Events/State/Types.hs +++ b/src/Events/State/Types.hs @@ -8,12 +8,11 @@ import Control.Lens (makeLenses) import Data.Taskell.Lists (Lists) -import UI.Field (Field) +import Types (Pointer) +import UI.Draw.Field (Field) import qualified Events.State.Types.Mode as M (Mode) -type Pointer = (Int, Int) - data State = State { _mode :: M.Mode , _lists :: Lists @@ -23,6 +22,7 @@ , _io :: Maybe Lists , _height :: Int , _searchTerm :: Maybe Field + , _time :: UTCTime } deriving (Eq, Show) -- create lenses diff --git a/src/Events/State/Types/Mode.hs b/src/Events/State/Types/Mode.hs --- a/src/Events/State/Types/Mode.hs +++ b/src/Events/State/Types/Mode.hs @@ -4,7 +4,9 @@ import ClassyPrelude -import UI.Field (Field) +import Data.Taskell.Task (Task) +import Types (Pointer) +import UI.Draw.Field (Field) data DetailMode = DetailNormal @@ -20,6 +22,8 @@ data ModalType = Help | MoveTo + | Due (Seq (Pointer, Task)) + Int | Detail DetailItem DetailMode deriving (Eq, Show) diff --git a/src/IO/Config.hs b/src/IO/Config.hs --- a/src/IO/Config.hs +++ b/src/IO/Config.hs @@ -36,6 +36,9 @@ , github :: GitHub.Config } +debugging :: Config -> Bool +debugging config = General.debug (general config) + defaultConfig :: Config defaultConfig = Config diff --git a/src/IO/Config/General.hs b/src/IO/Config/General.hs --- a/src/IO/Config/General.hs +++ b/src/IO/Config/General.hs @@ -8,10 +8,11 @@ data Config = Config { filename :: FilePath + , debug :: Bool } defaultConfig :: Config -defaultConfig = Config {filename = "taskell.md"} +defaultConfig = Config {filename = "taskell.md", debug = False} parser :: IniParser Config parser = @@ -20,4 +21,5 @@ "general" (do filenameCf <- maybe (filename defaultConfig) unpack . (noEmpty =<<) <$> fieldMb "filename" - pure Config {filename = filenameCf}) + debugCf <- fieldFlagDef "debug" False + pure Config {filename = filenameCf, debug = debugCf}) diff --git a/src/IO/Keyboard.hs b/src/IO/Keyboard.hs --- a/src/IO/Keyboard.hs +++ b/src/IO/Keyboard.hs @@ -43,6 +43,7 @@ [ (BChar 'q', A.Quit) , (BChar 'u', A.Undo) , (BChar '/', A.Search) + , (BChar '!', A.Due) , (BChar '?', A.Help) , (BChar 'k', A.Previous) , (BChar 'j', A.Next) @@ -52,6 +53,7 @@ , (BChar 'a', A.New) , (BChar 'O', A.NewAbove) , (BChar 'o', A.NewBelow) + , (BChar '+', A.Duplicate) , (BChar 'e', A.Edit) , (BChar 'A', A.Edit) , (BChar 'i', A.Edit) @@ -59,11 +61,12 @@ , (BChar 'D', A.Delete) , (BKey "Enter", A.Detail) , (BChar '@', A.DueDate) + , (BKey "Backspace", A.ClearDate) , (BChar 'K', A.MoveUp) , (BChar 'J', A.MoveDown) , (BChar 'H', A.MoveLeft) , (BChar 'L', A.MoveRight) - , (BKey "Space", A.MoveRight) + , (BKey "Space", A.Complete) , (BChar 'm', A.MoveMenu) , (BChar 'N', A.ListNew) , (BChar 'E', A.ListEdit) diff --git a/src/IO/Markdown/Internal.hs b/src/IO/Markdown/Internal.hs --- a/src/IO/Markdown/Internal.hs +++ b/src/IO/Markdown/Internal.hs @@ -8,7 +8,7 @@ import Control.Lens ((^.)) import Data.Sequence (adjust') -import Data.Text as T (dropAround, splitOn, strip) +import Data.Text as T (splitOn, strip) import Data.Text.Encoding (decodeUtf8With) import Data.Taskell.Date (dayToOutput) @@ -23,9 +23,6 @@ taskOutput, titleOutput) -- parse code -trimTilde :: Text -> Text -trimTilde = strip . T.dropAround (== '~') - addSubItem :: Text -> Lists -> Lists addSubItem t ls = adjust' updateList i ls where @@ -33,7 +30,6 @@ st | "[ ] " `isPrefixOf` t = ST.new (drop 4 t) False | "[x] " `isPrefixOf` t = ST.new (drop 4 t) True - | "~" `isPrefixOf` t = ST.new (trimTilde t) True | otherwise = ST.new t False updateList l = updateFn j (T.addSubtask st) l where diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 --- /dev/null +++ b/src/Types.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Types where + +import ClassyPrelude + +newtype ListIndex = ListIndex + { showListIndex :: Int + } deriving (Show, Eq, Ord) + +newtype TaskIndex = TaskIndex + { showTaskIndex :: Int + } deriving (Show, Eq, Ord) + +type Pointer = (ListIndex, TaskIndex) diff --git a/src/UI/Draw.hs b/src/UI/Draw.hs --- a/src/UI/Draw.hs +++ b/src/UI/Draw.hs @@ -1,6 +1,4 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE LambdaCase #-} module UI.Draw ( draw @@ -12,272 +10,26 @@ import Control.Lens ((^.)) import Control.Monad.Reader (runReader) -import Data.Char (chr, ord) -import Data.Sequence (mapWithIndex) import Brick -import Data.Taskell.Date (Day, dayToText, deadline) -import Data.Taskell.List (List, tasks, title) -import Data.Taskell.Lists (Lists, count) -import qualified Data.Taskell.Task as T (Task, contains, countCompleteSubtasks, countSubtasks, - description, due, hasSubtasks, name) -import Events.State (normalise) -import Events.State.Types (Pointer, State, current, height, lists, mode, path, - searchTerm) -import Events.State.Types.Mode (DetailMode (..), InsertType (..), ModalType (..), - Mode (..)) -import IO.Config.Layout (Config, columnPadding, columnWidth, descriptionIndicator) -import IO.Keyboard.Types (Bindings) -import UI.Field (Field, field, getText, textField, widgetFromMaybe) -import UI.Modal (showModal) -import UI.Theme -import UI.Types (ListIndex (..), ResourceName (..), TaskIndex (..)) - --- | Draw needs to know various pieces of information, so keep track of them in a record -data DrawState = DrawState - { dsLists :: Lists - , dsMode :: Mode - , dsLayout :: Config - , dsPath :: FilePath - , dsToday :: Day - , dsCurrent :: Pointer - , dsField :: Maybe Field - , dsEditingTitle :: Bool - , dsSearchTerm :: Maybe Field - } - --- | Use a Reader to pass around DrawState -type ReaderDrawState = ReaderT DrawState Identity - --- | Takes a task's 'due' property and renders a date with appropriate styling (e.g. red if overdue) -renderDate :: Maybe Day -> ReaderDrawState (Maybe (Widget ResourceName)) -renderDate dueDay = do - today <- dsToday <$> ask -- get the value of `today` from DrawState - let attr = withAttr . dlToAttr . deadline today <$> dueDay -- create a `Maybe (Widget -> Widget)` attribute function - widget = txt . dayToText today <$> dueDay -- get the formatted due date `Maybe Text` - pure $ attr <*> widget - --- | Renders the appropriate completed sub task count e.g. "[2/3]" -renderSubtaskCount :: T.Task -> Widget ResourceName -renderSubtaskCount task = - txt $ concat ["[", tshow $ T.countCompleteSubtasks task, "/", tshow $ T.countSubtasks task, "]"] - --- | Renders the appropriate indicators: description, sub task count, and due date -indicators :: T.Task -> ReaderDrawState (Widget ResourceName) -indicators task = do - dateWidget <- renderDate (task ^. T.due) -- get the due date widget - descIndicator <- descriptionIndicator . dsLayout <$> ask - pure . hBox $ - padRight (Pad 1) <$> - catMaybes - [ const (txt descIndicator) <$> task ^. T.description -- show the description indicator if one is set - , bool Nothing (Just (renderSubtaskCount task)) (T.hasSubtasks task) -- if it has subtasks, render the sub task count - , dateWidget - ] - --- | Renders an individual task -renderTask' :: Int -> Int -> T.Task -> ReaderDrawState (Widget ResourceName) -renderTask' listIndex taskIndex task = do - eTitle <- dsEditingTitle <$> ask -- is the title being edited? (for visibility) - selected <- (== (listIndex, taskIndex)) . dsCurrent <$> ask -- is the current task selected? - taskField <- dsField <$> ask -- get the field, if it's being edited - after <- indicators task -- get the indicators widget - let text = task ^. T.name - name = RNTask (ListIndex listIndex, TaskIndex taskIndex) - widget = textField text - widget' = widgetFromMaybe widget taskField - pure $ - cached name . - (if selected && not eTitle - then visible - else id) . - padBottom (Pad 1) . - (<=> withAttr disabledAttr after) . - withAttr - (if selected - then taskCurrentAttr - else taskAttr) $ - if selected && not eTitle - then widget' - else widget - -renderTask :: Int -> Int -> T.Task -> ReaderDrawState (Widget ResourceName) -renderTask listIndex taskIndex task = do - searchT <- asks dsSearchTerm - case searchT of - Nothing -> renderTask' listIndex taskIndex task - Just term -> - if T.contains (getText term) task - then renderTask' listIndex taskIndex task - else pure emptyWidget - --- | Gets the relevant column prefix - number in normal mode, letter in moveTo -columnPrefix :: Int -> Int -> ReaderDrawState Text -columnPrefix selectedList i = do - m <- dsMode <$> ask - if moveTo m - then do - let col = chr (i + ord 'a') - pure $ - if i /= selectedList && i >= 0 && i <= 26 - then singleton col <> ". " - else "" - else do - let col = i + 1 - pure $ - if col >= 1 && col <= 9 - then tshow col <> ". " - else "" - --- | Renders the title for a list -renderTitle :: Int -> List -> ReaderDrawState (Widget ResourceName) -renderTitle listIndex list = do - (selectedList, selectedTask) <- dsCurrent <$> ask - editing <- (selectedList == listIndex &&) . dsEditingTitle <$> ask - titleField <- dsField <$> ask - col <- txt <$> columnPrefix selectedList listIndex - let text = list ^. title - attr = - if selectedList == listIndex - then titleCurrentAttr - else titleAttr - widget = textField text - widget' = widgetFromMaybe widget titleField - title' = - padBottom (Pad 1) . withAttr attr . (col <+>) $ - if editing - then widget' - else widget - pure $ - if editing || selectedList /= listIndex || selectedTask == 0 - then visible title' - else title' - --- | Renders a list -renderList :: Int -> List -> ReaderDrawState (Widget ResourceName) -renderList listIndex list = do - layout <- dsLayout <$> ask - eTitle <- dsEditingTitle <$> ask - titleWidget <- renderTitle listIndex list - (currentList, _) <- dsCurrent <$> ask - taskWidgets <- sequence $ renderTask listIndex `mapWithIndex` (list ^. tasks) - let widget = - (if not eTitle - then cached (RNList listIndex) - else id) . - padLeftRight (columnPadding layout) . - hLimit (columnWidth layout) . - viewport (RNList listIndex) Vertical . vBox . (titleWidget :) $ - toList taskWidgets - pure $ - if currentList == listIndex - then visible widget - else widget - --- | Renders the search area -renderSearch :: Widget ResourceName -> ReaderDrawState (Widget ResourceName) -renderSearch mainWidget = do - m <- asks dsMode - term <- asks dsSearchTerm - case term of - Just searchField -> do - colPad <- columnPadding . dsLayout <$> ask - let attr = - withAttr $ - case m of - Search -> taskCurrentAttr - _ -> taskAttr - let widget = attr . padLeftRight colPad $ txt "/" <+> field searchField - pure $ mainWidget <=> widget - _ -> pure mainWidget - --- | Render the status bar -getPosition :: ReaderDrawState Text -getPosition = do - (col, pos) <- asks dsCurrent - len <- count col <$> asks dsLists - let posNorm = - if len > 0 - then pos + 1 - else 0 - pure $ tshow posNorm <> "/" <> tshow len - -modeToText :: Maybe Field -> Mode -> Text -modeToText fld = - \case - Normal -> - case fld of - Nothing -> "NORMAL" - Just _ -> "NORMAL + SEARCH" - Insert {} -> "INSERT" - Modal Help -> "HELP" - Modal MoveTo -> "MOVE" - Modal Detail {} -> "DETAIL" - Search {} -> "SEARCH" - _ -> "" - -getMode :: ReaderDrawState Text -getMode = modeToText <$> asks dsSearchTerm <*> asks dsMode - -renderStatusBar :: ReaderDrawState (Widget ResourceName) -renderStatusBar = do - topPath <- pack <$> asks dsPath - colPad <- columnPadding <$> asks dsLayout - posTxt <- getPosition - modeTxt <- getMode - let titl = padLeftRight colPad $ txt topPath - let pos = padRight (Pad colPad) $ txt posTxt - let md = txt modeTxt - let bar = padRight Max (titl <+> md) <+> pos - pure . padTop (Pad 1) $ withAttr statusBarAttr bar - --- | Renders the main widget -main :: ReaderDrawState (Widget ResourceName) -main = do - ls <- dsLists <$> ask - listWidgets <- toList <$> sequence (renderList `mapWithIndex` ls) - let mainWidget = viewport RNLists Horizontal . padTopBottom 1 $ hBox listWidgets - statusBar <- renderStatusBar - renderSearch (mainWidget <=> statusBar) - -getField :: Mode -> Maybe Field -getField (Insert _ _ f) = Just f -getField _ = Nothing - -editingTitle :: Mode -> Bool -editingTitle (Insert IList _ _) = True -editingTitle _ = False - -moveTo :: Mode -> Bool -moveTo (Modal MoveTo) = True -moveTo _ = False +import Events.State (normalise) +import Events.State.Types (State, mode) +import Events.State.Types.Mode (DetailMode (..), ModalType (..), Mode (..)) +import IO.Config.Layout (Config) +import IO.Keyboard.Types (Bindings) +import UI.Draw.Main (renderMain) +import UI.Draw.Modal (renderModal) +import UI.Draw.Types (DrawState (DrawState), ReaderDrawState, TWidget) +import UI.Types (ResourceName (..)) -- draw -drawR :: Int -> State -> Bindings -> ReaderDrawState [Widget ResourceName] -drawR ht normalisedState bindings = do - modal <- showModal ht bindings normalisedState <$> asks dsToday - mn <- main - pure [modal, mn] +renderApp :: ReaderDrawState [TWidget] +renderApp = sequence [renderModal, renderMain] -draw :: Config -> Bindings -> Day -> State -> [Widget ResourceName] -draw layout bindings today state = runReader (drawR ht normalisedState bindings) drawState - where - normalisedState = normalise state - stateMode = state ^. mode - ht = state ^. height - drawState = - DrawState - { dsLists = normalisedState ^. lists - , dsMode = stateMode - , dsLayout = layout - , dsPath = normalisedState ^. path - , dsToday = today - , dsField = getField stateMode - , dsCurrent = normalisedState ^. current - , dsEditingTitle = editingTitle stateMode - , dsSearchTerm = normalisedState ^. searchTerm - } +draw :: Config -> Bindings -> Bool -> State -> [TWidget] +draw layout bindings debug state = + runReader renderApp (DrawState layout bindings debug (normalise state)) -- cursors chooseCursor :: State -> [CursorLocation ResourceName] -> Maybe (CursorLocation ResourceName) diff --git a/src/UI/Draw/Field.hs b/src/UI/Draw/Field.hs new file mode 100644 --- /dev/null +++ b/src/UI/Draw/Field.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module UI.Draw.Field where + +import ClassyPrelude + +import qualified Data.List as L (scanl1) +import qualified Data.Text as T (splitAt, takeEnd) + +import qualified Brick as B (Location (Location), Size (Fixed), Widget (Widget), + availWidth, getContext, render, showCursor, txt, + vBox) +import qualified Brick.Widgets.Core as B (textWidth) +import qualified Graphics.Text.Width as V (safeWcwidth) +import qualified Graphics.Vty.Input.Events as V (Event (..), Key (..)) + +import qualified UI.Types as UI (ResourceName (RNCursor)) + +data Field = Field + { _text :: Text + , _cursor :: Int + } deriving (Eq, Show) + +blankField :: Field +blankField = Field "" 0 + +event :: V.Event -> Field -> Field +event (V.EvKey (V.KChar '\t') _) f = f +event (V.EvPaste bs) f = insertText (decodeUtf8 bs) f +event (V.EvKey V.KBS _) f = backspace f +event (V.EvKey V.KLeft _) f = updateCursor (-1) f +event (V.EvKey V.KRight _) f = updateCursor 1 f +event (V.EvKey (V.KChar char) _) f = insertCharacter char f +event _ f = f + +updateCursor :: Int -> Field -> Field +updateCursor dir (Field text cursor) = Field text newCursor + where + next = cursor + dir + limit = length text + newCursor + | next <= 0 = 0 + | next > limit = limit + | otherwise = next + +backspace :: Field -> Field +backspace (Field text cursor) = + let (start, end) = T.splitAt cursor text + in case fromNullable start of + Nothing -> Field end cursor + Just start' -> Field (init start' <> end) (cursor - 1) + +insertCharacter :: Char -> Field -> Field +insertCharacter char (Field text cursor) = Field newText newCursor + where + (start, end) = T.splitAt cursor text + newText = snoc start char <> end + newCursor = cursor + 1 + +insertText :: Text -> Field -> Field +insertText insert (Field text cursor) = Field newText newCursor + where + (start, end) = T.splitAt cursor text + newText = concat [start, insert, end] + newCursor = cursor + length insert + +widthFold :: [Int] -> Char -> [Int] +widthFold l t = l <> [V.safeWcwidth t] + +cursorPosition :: [Text] -> Int -> Int -> (Int, Int) +cursorPosition lns width cursor = + if x == width + then (0, y + 1) -- go to next line if at end of line + else (x, y) + where + parts = foldl' widthFold [] <$> lns -- list of list of individual character lengths + lengths = length <$> parts -- list of line lengths + cumulative = L.scanl1 (+) lengths -- cumulative total of line lengths + above = takeWhile (< cursor) cumulative -- lines above the cursor + y = length above -- number of lines above + adjustedCursor = cursor - fromMaybe 0 (lastMay above) -- subtract lines above from cursor position + cumulativeWidths = L.scanl1 (+) <$> index parts y -- get cumulative widths for current line + x = fromMaybe 0 $ flip index (adjustedCursor - 1) =<< cumulativeWidths + +getText :: Field -> Text +getText (Field text _) = text + +textToField :: Text -> Field +textToField text = Field text (length text) + +field :: Field -> B.Widget UI.ResourceName +field (Field text cursor) = + B.Widget B.Fixed B.Fixed $ do + width <- B.availWidth <$> B.getContext + let (wrapped, offset) = wrap width text + location = cursorPosition wrapped width (cursor - offset) + B.render $ + if null text + then B.showCursor UI.RNCursor (B.Location (0, 0)) $ B.txt " " + else B.showCursor UI.RNCursor (B.Location location) . B.vBox $ B.txt <$> wrapped + +widgetFromMaybe :: B.Widget UI.ResourceName -> Maybe Field -> B.Widget UI.ResourceName +widgetFromMaybe _ (Just f) = field f +widgetFromMaybe w Nothing = w + +textField :: Text -> B.Widget UI.ResourceName +textField text = + B.Widget B.Fixed B.Fixed $ do + width <- B.availWidth <$> B.getContext + let (wrapped, _) = wrap width text + B.render $ + if null text + then B.txt "---" + else B.vBox $ B.txt <$> wrapped + +-- wrap +wrap :: Int -> Text -> ([Text], Int) +wrap width = foldl' (combine width) ([""], 0) . spl + +spl' :: [Text] -> Char -> [Text] +spl' ts c + | c == ' ' = ts <> [" "] <> [""] + | otherwise = + case fromNullable ts of + Just ts' -> init ts' <> [snoc (last ts') c] + Nothing -> [singleton c] + +spl :: Text -> [Text] +spl = foldl' spl' [""] + +combine :: Int -> ([Text], Int) -> Text -> ([Text], Int) +combine width (acc, offset) s + | newline && s == " " = (acc, offset + 1) + | T.takeEnd 1 l == " " && s == " " = (acc, offset + 1) + | newline = (acc <> [s], offset) + | otherwise = (append (l <> s) acc, offset) + where + l = maybe "" last (fromNullable acc) + newline = B.textWidth l + B.textWidth s > width + +append :: Text -> [Text] -> [Text] +append s l = + case fromNullable l of + Just l' -> init l' <> [s] + Nothing -> l <> [s] diff --git a/src/UI/Draw/Main.hs b/src/UI/Draw/Main.hs new file mode 100644 --- /dev/null +++ b/src/UI/Draw/Main.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module UI.Draw.Main + ( renderMain + ) where + +import ClassyPrelude + +import Brick +import Control.Lens ((^.)) +import Data.Sequence (mapWithIndex) + +import Events.State.Types (lists) +import UI.Draw.Main.List (renderList) +import UI.Draw.Main.Search (renderSearch) +import UI.Draw.Main.StatusBar (renderStatusBar) +import UI.Draw.Types (DSWidget, DrawState (..)) +import UI.Types (ResourceName (..)) + +renderMain :: DSWidget +renderMain = do + ls <- (^. lists) <$> asks dsState + listWidgets <- toList <$> sequence (renderList `mapWithIndex` ls) + let mainWidget = viewport RNLists Horizontal . padTopBottom 1 $ hBox listWidgets + statusBar <- renderStatusBar + renderSearch (mainWidget <=> statusBar) diff --git a/src/UI/Draw/Main/List.hs b/src/UI/Draw/Main/List.hs new file mode 100644 --- /dev/null +++ b/src/UI/Draw/Main/List.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module UI.Draw.Main.List + ( renderList + ) where + +import ClassyPrelude + +import Control.Lens ((^.)) + +import Data.Char (chr, ord) +import Data.Sequence (mapWithIndex) + +import Brick + +import Data.Taskell.List (List, tasks, title) +import Events.State.Types (current, mode) +import IO.Config.Layout (columnPadding, columnWidth) +import Types (ListIndex (ListIndex), TaskIndex (TaskIndex)) +import UI.Draw.Field (textField, widgetFromMaybe) +import UI.Draw.Mode +import UI.Draw.Task (renderTask) +import UI.Draw.Types (DSWidget, DrawState (..), ReaderDrawState) +import UI.Theme +import UI.Types (ResourceName (..)) + +-- | Gets the relevant column prefix - number in normal mode, letter in moveTo +columnPrefix :: Int -> Int -> ReaderDrawState Text +columnPrefix selectedList i = do + m <- (^. mode) <$> asks dsState + if moveTo m + then do + let col = chr (i + ord 'a') + pure $ + if i /= selectedList && i >= 0 && i <= 26 + then singleton col <> ". " + else "" + else do + let col = i + 1 + pure $ + if col >= 1 && col <= 9 + then tshow col <> ". " + else "" + +-- | Renders the title for a list +renderTitle :: Int -> List -> DSWidget +renderTitle listIndex list = do + (ListIndex selectedList, TaskIndex selectedTask) <- (^. current) <$> asks dsState + editing <- (selectedList == listIndex &&) . editingTitle . (^. mode) <$> asks dsState + titleField <- getField . (^. mode) <$> asks dsState + col <- txt <$> columnPrefix selectedList listIndex + let text = list ^. title + attr = + if selectedList == listIndex + then titleCurrentAttr + else titleAttr + widget = textField text + widget' = widgetFromMaybe widget titleField + title' = + padBottom (Pad 1) . withAttr attr . (col <+>) $ + if editing + then widget' + else widget + pure $ + if editing || selectedList /= listIndex || selectedTask == 0 + then visible title' + else title' + +-- | Renders a list +renderList :: Int -> List -> DSWidget +renderList listIndex list = do + layout <- dsLayout <$> ask + eTitle <- editingTitle . (^. mode) <$> asks dsState + titleWidget <- renderTitle listIndex list + (ListIndex currentList, _) <- (^. current) <$> asks dsState + taskWidgets <- + sequence $ + renderTask (RNTask . (ListIndex listIndex, ) . TaskIndex) listIndex `mapWithIndex` + (list ^. tasks) + let widget = + (if not eTitle + then cached (RNList listIndex) + else id) . + padLeftRight (columnPadding layout) . + hLimit (columnWidth layout) . + viewport (RNList listIndex) Vertical . vBox . (titleWidget :) $ + toList taskWidgets + pure $ + if currentList == listIndex + then visible widget + else widget diff --git a/src/UI/Draw/Main/Search.hs b/src/UI/Draw/Main/Search.hs new file mode 100644 --- /dev/null +++ b/src/UI/Draw/Main/Search.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module UI.Draw.Main.Search + ( renderSearch + ) where + +import Brick +import ClassyPrelude +import Control.Lens ((^.)) + +import Events.State.Types (mode, searchTerm) +import Events.State.Types.Mode (Mode (..)) +import IO.Config.Layout (columnPadding) +import UI.Draw.Field (field) +import UI.Draw.Types (DSWidget, DrawState (..)) +import UI.Theme +import UI.Types (ResourceName (..)) + +renderSearch :: Widget ResourceName -> DSWidget +renderSearch mainWidget = do + m <- (^. mode) <$> asks dsState + term <- (^. searchTerm) <$> asks dsState + case term of + Just searchField -> do + colPad <- columnPadding . dsLayout <$> ask + let attr = + withAttr $ + case m of + Search -> taskCurrentAttr + _ -> taskAttr + let widget = attr . padLeftRight colPad $ txt "/" <+> field searchField + pure $ mainWidget <=> widget + _ -> pure mainWidget diff --git a/src/UI/Draw/Main/StatusBar.hs b/src/UI/Draw/Main/StatusBar.hs new file mode 100644 --- /dev/null +++ b/src/UI/Draw/Main/StatusBar.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} + +module UI.Draw.Main.StatusBar + ( renderStatusBar + ) where + +import ClassyPrelude + +import Control.Lens ((^.)) + +import Brick + +import Data.Taskell.Lists (count) +import Events.State.Types (current, lists, mode, path, searchTerm) + +import Events.State.Types.Mode (ModalType (..), Mode (..)) +import IO.Config.Layout (columnPadding) +import Types (ListIndex (ListIndex), TaskIndex (TaskIndex)) +import UI.Draw.Field (Field) +import UI.Draw.Types (DSWidget, DrawState (..), ReaderDrawState) +import UI.Theme + +getPosition :: ReaderDrawState Text +getPosition = do + (ListIndex col, TaskIndex pos) <- (^. current) <$> asks dsState + len <- count col . (^. lists) <$> asks dsState + let posNorm = + if len > 0 + then pos + 1 + else 0 + pure $ tshow posNorm <> "/" <> tshow len + +modeToText :: Maybe Field -> Mode -> ReaderDrawState Text +modeToText fld md = do + debug <- asks dsDebug + pure $ + if debug + then tshow md + else case md of + Normal -> + case fld of + Nothing -> "NORMAL" + Just _ -> "NORMAL + SEARCH" + Insert {} -> "INSERT" + Modal Help -> "HELP" + Modal MoveTo -> "MOVE" + Modal Detail {} -> "DETAIL" + Modal Due {} -> "DUE" + Search {} -> "SEARCH" + _ -> "" + +getMode :: ReaderDrawState Text +getMode = do + state <- asks dsState + modeToText (state ^. searchTerm) (state ^. mode) + +renderStatusBar :: DSWidget +renderStatusBar = do + topPath <- pack . (^. path) <$> asks dsState + colPad <- columnPadding <$> asks dsLayout + posTxt <- getPosition + modeTxt <- getMode + let titl = padLeftRight colPad $ txt topPath + let pos = padRight (Pad colPad) $ txt posTxt + let md = txt modeTxt + let bar = padRight Max (titl <+> md) <+> pos + pure . padTop (Pad 1) $ withAttr statusBarAttr bar diff --git a/src/UI/Draw/Modal.hs b/src/UI/Draw/Modal.hs new file mode 100644 --- /dev/null +++ b/src/UI/Draw/Modal.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module UI.Draw.Modal + ( renderModal + ) where + +import ClassyPrelude + +import Control.Lens ((^.)) + +import Brick +import Brick.Widgets.Border +import Brick.Widgets.Center + +import Events.State.Types (height, mode) +import Events.State.Types.Mode (ModalType (..), Mode (..)) +import UI.Draw.Field (textField) +import UI.Draw.Modal.Detail (detail) +import UI.Draw.Modal.Due (due) +import UI.Draw.Modal.Help (help) +import UI.Draw.Modal.MoveTo (moveTo) +import UI.Draw.Types (DSWidget, DrawState (dsState), TWidget) +import UI.Theme (titleAttr) +import UI.Types (ResourceName (..)) + +surround :: (Text, TWidget) -> DSWidget +surround (title, widget) = do + ht <- (^. height) <$> asks dsState + let t = padBottom (Pad 1) . withAttr titleAttr $ textField title + pure . + padTopBottom 1 . + centerLayer . + border . + padTopBottom 1 . + padLeftRight 4 . vLimit (ht - 9) . hLimit 50 . (t <=>) . viewport RNModal Vertical $ + widget + +renderModal :: DSWidget +renderModal = do + md <- (^. mode) <$> asks dsState + case md of + Modal Help -> surround =<< help + Modal Detail {} -> surround =<< detail + Modal MoveTo -> surround =<< moveTo + Modal (Due tasks selected) -> surround =<< due tasks selected + _ -> pure emptyWidget diff --git a/src/UI/Draw/Modal/Detail.hs b/src/UI/Draw/Modal/Detail.hs new file mode 100644 --- /dev/null +++ b/src/UI/Draw/Modal/Detail.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module UI.Draw.Modal.Detail + ( detail + ) where + +import ClassyPrelude + +import Control.Lens ((^.)) + +import Data.Sequence (mapWithIndex) + +import Brick + +import Data.Taskell.Date (Day, dayToOutput, deadline) +import qualified Data.Taskell.Subtask as ST (Subtask, complete, name) +import Data.Taskell.Task (Task, description, due, name, subtasks) +import Events.State (getCurrentTask) +import Events.State.Modal.Detail (getCurrentItem, getField) +import Events.State.Types (time) +import Events.State.Types.Mode (DetailItem (..)) +import UI.Draw.Field (Field, textField, widgetFromMaybe) +import UI.Draw.Types (DrawState (..), ModalWidget, TWidget) +import UI.Theme (disabledAttr, dlToAttr, taskCurrentAttr, + titleCurrentAttr) + +renderSubtask :: Maybe Field -> DetailItem -> Int -> ST.Subtask -> TWidget +renderSubtask f current i subtask = padBottom (Pad 1) $ prefix <+> final + where + cur = + case current of + DetailItem c -> i == c + _ -> False + done = subtask ^. ST.complete + attr = + withAttr + (if cur + then taskCurrentAttr + else titleCurrentAttr) + prefix = + attr . txt $ + if done + then "[x] " + else "[ ] " + widget = textField (subtask ^. ST.name) + final + | cur = visible . attr $ widgetFromMaybe widget f + | not done = attr widget + | otherwise = widget + +renderSummary :: Maybe Field -> DetailItem -> Task -> TWidget +renderSummary f i task = padTop (Pad 1) $ padBottom (Pad 2) w' + where + w = textField $ fromMaybe "No description" (task ^. description) + w' = + case i of + DetailDescription -> visible $ widgetFromMaybe w f + _ -> w + +renderDate :: Day -> Maybe Field -> DetailItem -> Task -> TWidget +renderDate today field item task = + case item of + DetailDate -> visible $ prefix <+> widgetFromMaybe widget field + _ -> + case day of + Just d -> prefix <+> withAttr (dlToAttr (deadline today d)) widget + Nothing -> emptyWidget + where + day = task ^. due + prefix = txt "Due: " + widget = textField $ maybe "" dayToOutput day + +detail :: ModalWidget +detail = do + state <- asks dsState + let today = utctDay (state ^. time) + pure $ + fromMaybe ("Error", txt "Oops") $ do + task <- getCurrentTask state + i <- getCurrentItem state + let f = getField state + let sts = task ^. subtasks + w + | null sts = withAttr disabledAttr $ txt "No sub-tasks" + | otherwise = vBox . toList $ renderSubtask f i `mapWithIndex` sts + pure (task ^. name, renderDate today f i task <=> renderSummary f i task <=> w) diff --git a/src/UI/Draw/Modal/Due.hs b/src/UI/Draw/Modal/Due.hs new file mode 100644 --- /dev/null +++ b/src/UI/Draw/Modal/Due.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module UI.Draw.Modal.Due + ( due + ) where + +import ClassyPrelude + +import Brick +import Data.Taskell.Seq ((<#>)) + +import qualified Data.Taskell.Task as T (Task) +import Types (Pointer) +import UI.Draw.Task (TaskWidget (..), parts) +import UI.Draw.Types (DSWidget, ModalWidget) +import UI.Theme (taskAttr, taskCurrentAttr) +import UI.Types (ResourceName (RNDue)) + +renderTask :: Int -> Int -> T.Task -> DSWidget +renderTask current position task = do + (TaskWidget text date _ _) <- parts task + let selected = current == position + let attr = + if selected + then taskCurrentAttr + else taskAttr + let shw = + if selected + then visible + else id + pure . shw . cached (RNDue position) . padBottom (Pad 1) . withAttr attr $ vBox [date, text] + +due :: Seq (Pointer, T.Task) -> Int -> ModalWidget +due tasks selected = do + let items = snd <$> tasks + widgets <- sequence $ renderTask selected <#> items + pure + ( "Due Tasks" + , if null items + then txt "No due tasks" + else vBox $ toList widgets) diff --git a/src/UI/Draw/Modal/Help.hs b/src/UI/Draw/Modal/Help.hs new file mode 100644 --- /dev/null +++ b/src/UI/Draw/Modal/Help.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module UI.Draw.Modal.Help + ( help + ) where + +import ClassyPrelude + +import Brick +import Data.Text as T (justifyRight) + +import Events.Actions.Types as A (ActionType (..)) +import IO.Keyboard.Types (bindingsToText) + +import IO.Keyboard.Types (Bindings) +import UI.Draw.Field (textField) +import UI.Draw.Types (DrawState (dsBindings), ModalWidget, TWidget) +import UI.Theme (taskCurrentAttr) + +descriptions :: [([ActionType], Text)] +descriptions = + [ ([A.Help], "Show this list of controls") + , ([A.Due], "Show tasks with due dates") + , ([A.Previous, A.Next, A.Left, A.Right], "Move down / up / left / right") + , ([A.Bottom], "Go to bottom of list") + , ([A.New], "Add a task") + , ([A.NewAbove, A.NewBelow], "Add a task above / below") + , ([A.Duplicate], "Duplicate a task") + , ([A.Edit], "Edit a task") + , ([A.Clear], "Change task") + , ([A.Detail], "Show task details / Edit task description") + , ([A.DueDate], "Add/edit due date (yyyy-mm-dd)") + , ([A.ClearDate], "Removes due date") + , ([A.MoveUp, A.MoveDown], "Shift task down / up") + , ([A.MoveLeft, A.MoveRight], "Shift task left / right") + , ([A.Complete], "Move task to last list and remove any due dates") + , ([A.MoveMenu], "Move task to specific list") + , ([A.Delete], "Delete task") + , ([A.Undo], "Undo") + , ([A.ListNew], "New list") + , ([A.ListEdit], "Edit list title") + , ([A.ListDelete], "Delete list") + , ([A.ListLeft, A.ListRight], "Move list left / right") + , ([A.Search], "Search") + , ([A.Quit], "Quit") + ] + +generate :: Bindings -> [([Text], Text)] +generate bindings = first (intercalate ", " . bindingsToText bindings <$>) <$> descriptions + +format :: ([Text], Text) -> (Text, Text) +format = first (intercalate " / ") + +line :: Int -> (Text, Text) -> TWidget +line m (l, r) = left <+> right + where + left = padRight (Pad 2) . withAttr taskCurrentAttr . txt $ justifyRight m ' ' l + right = textField r + +help :: ModalWidget +help = do + bindings <- asks dsBindings + let ls = format <$> generate bindings + let m = foldl' max 0 $ length . fst <$> ls + let w = vBox $ line m <$> ls + pure ("Controls", w) diff --git a/src/UI/Draw/Modal/MoveTo.hs b/src/UI/Draw/Modal/MoveTo.hs new file mode 100644 --- /dev/null +++ b/src/UI/Draw/Modal/MoveTo.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module UI.Draw.Modal.MoveTo + ( moveTo + ) where + +import ClassyPrelude + +import Control.Lens ((^.)) + +import Brick + +import Data.Taskell.List (title) +import Events.State.Types (current, lists) +import Types (showListIndex) +import UI.Draw.Field (textField) +import UI.Draw.Types (DrawState (dsState), ModalWidget) +import UI.Theme (taskCurrentAttr) + +moveTo :: ModalWidget +moveTo = do + skip <- showListIndex . fst . (^. current) <$> asks dsState + ls <- toList . (^. lists) <$> asks dsState + let titles = textField . (^. title) <$> ls + let letter a = + padRight (Pad 1) . hBox $ + [txt "[", withAttr taskCurrentAttr $ txt (singleton a), txt "]"] + let letters = letter <$> ['a' ..] + let remove i l = take i l <> drop (i + 1) l + let output (l, t) = l <+> t + let widget = vBox $ output <$> remove skip (zip letters titles) + pure ("Move To:", widget) diff --git a/src/UI/Draw/Mode.hs b/src/UI/Draw/Mode.hs new file mode 100644 --- /dev/null +++ b/src/UI/Draw/Mode.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module UI.Draw.Mode where + +import ClassyPrelude + +import Events.State.Types.Mode (InsertType (..), ModalType (..), Mode (..)) +import UI.Draw.Field (Field) + +getField :: Mode -> Maybe Field +getField (Insert _ _ f) = Just f +getField _ = Nothing + +editingTitle :: Mode -> Bool +editingTitle (Insert IList _ _) = True +editingTitle _ = False + +moveTo :: Mode -> Bool +moveTo (Modal MoveTo) = True +moveTo _ = False diff --git a/src/UI/Draw/Task.hs b/src/UI/Draw/Task.hs new file mode 100644 --- /dev/null +++ b/src/UI/Draw/Task.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module UI.Draw.Task + ( TaskWidget(..) + , renderTask + , parts + ) where + +import ClassyPrelude + +import Control.Lens ((^.)) + +import Brick + +import Data.Taskell.Date (dayToText, deadline) +import qualified Data.Taskell.Task as T (Task, contains, countCompleteSubtasks, countSubtasks, + description, due, hasSubtasks, name) +import Events.State.Types (current, mode, searchTerm, time) +import IO.Config.Layout (descriptionIndicator) +import Types (ListIndex (..), TaskIndex (..)) +import UI.Draw.Field (getText, textField, widgetFromMaybe) +import UI.Draw.Mode +import UI.Draw.Types (DSWidget, DrawState (..), ReaderDrawState, TWidget) +import UI.Theme +import UI.Types (ResourceName) + +data TaskWidget = TaskWidget + { textW :: TWidget + , dateW :: TWidget + , summaryW :: TWidget + , subtasksW :: TWidget + } + +-- | Takes a task's 'due' property and renders a date with appropriate styling (e.g. red if overdue) +renderDate :: T.Task -> DSWidget +renderDate task = do + today <- utctDay . (^. time) <$> asks dsState + pure . fromMaybe emptyWidget $ + (\day -> withAttr (dlToAttr $ deadline today day) (txt $ dayToText today day)) <$> + task ^. T.due + +-- | Renders the appropriate completed sub task count e.g. "[2/3]" +renderSubtaskCount :: T.Task -> DSWidget +renderSubtaskCount task = + pure . fromMaybe emptyWidget $ bool Nothing (Just indicator) (T.hasSubtasks task) + where + complete = tshow $ T.countCompleteSubtasks task + total = tshow $ T.countSubtasks task + indicator = txt $ concat ["[", complete, "/", total, "]"] + +-- | Renders the description indicator +renderDescIndicator :: T.Task -> DSWidget +renderDescIndicator task = do + indicator <- descriptionIndicator <$> asks dsLayout + pure . fromMaybe emptyWidget $ const (txt indicator) <$> task ^. T.description -- show the description indicator if one is set + +-- | Renders the task text +renderText :: T.Task -> DSWidget +renderText task = pure $ textField (task ^. T.name) + +-- | Renders the appropriate indicators: description, sub task count, and due date +indicators :: T.Task -> DSWidget +indicators task = do + widgets <- sequence (($ task) <$> [renderDescIndicator, renderSubtaskCount, renderDate]) + pure . hBox $ padRight (Pad 1) <$> widgets + +-- | The individual parts of a task widget +parts :: T.Task -> ReaderDrawState TaskWidget +parts task = + TaskWidget <$> renderText task <*> renderDate task <*> renderDescIndicator task <*> + renderSubtaskCount task + +-- | Renders an individual task +renderTask' :: (Int -> ResourceName) -> Int -> Int -> T.Task -> DSWidget +renderTask' rn listIndex taskIndex task = do + eTitle <- editingTitle . (^. mode) <$> asks dsState -- is the title being edited? (for visibility) + selected <- (== (ListIndex listIndex, TaskIndex taskIndex)) . (^. current) <$> asks dsState -- is the current task selected? + taskField <- getField . (^. mode) <$> asks dsState -- get the field, if it's being edited + after <- indicators task -- get the indicators widget + widget <- renderText task + let name = rn taskIndex + widget' = widgetFromMaybe widget taskField + pure $ + cached name . + (if selected && not eTitle + then visible + else id) . + padBottom (Pad 1) . + (<=> withAttr disabledAttr after) . + withAttr + (if selected + then taskCurrentAttr + else taskAttr) $ + if selected && not eTitle + then widget' + else widget + +renderTask :: (Int -> ResourceName) -> Int -> Int -> T.Task -> DSWidget +renderTask rn listIndex taskIndex task = do + searchT <- (getText <$>) . (^. searchTerm) <$> asks dsState + let taskWidget = renderTask' rn listIndex taskIndex task + case searchT of + Nothing -> taskWidget + Just term -> + if T.contains term task + then taskWidget + else pure emptyWidget diff --git a/src/UI/Draw/Types.hs b/src/UI/Draw/Types.hs new file mode 100644 --- /dev/null +++ b/src/UI/Draw/Types.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module UI.Draw.Types where + +import ClassyPrelude + +import Brick (Widget) +import Events.State.Types (State) +import IO.Config.Layout (Config) +import IO.Keyboard.Types (Bindings) +import UI.Types (ResourceName) + +data DrawState = DrawState + { dsLayout :: Config + , dsBindings :: Bindings + , dsDebug :: Bool + , dsState :: State + } + +-- | Use a Reader to pass around DrawState +type ReaderDrawState = ReaderT DrawState Identity + +-- | Aliases for common combinations +type TWidget = Widget ResourceName + +type ModalWidget = ReaderDrawState (Text, TWidget) + +type DSWidget = ReaderDrawState TWidget diff --git a/src/UI/Field.hs b/src/UI/Field.hs deleted file mode 100644 --- a/src/UI/Field.hs +++ /dev/null @@ -1,138 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module UI.Field where - -import ClassyPrelude - -import qualified Data.List as L (scanl1) -import qualified Data.Text as T (splitAt, takeEnd) - -import qualified Brick as B (Location (Location), Size (Fixed), Widget (Widget), - availWidth, getContext, render, showCursor, txt, - vBox) -import qualified Brick.Widgets.Core as B (textWidth) -import qualified Graphics.Vty.Input.Events as V (Event (..), Key (..)) - -import qualified UI.Types as UI (ResourceName (RNCursor)) - -data Field = Field - { _text :: Text - , _cursor :: Int - } deriving (Eq, Show) - -blankField :: Field -blankField = Field "" 0 - -event :: V.Event -> Field -> Field -event (V.EvKey (V.KChar '\t') _) f = f -event (V.EvPaste bs) f = insertText (decodeUtf8 bs) f -event (V.EvKey V.KBS _) f = backspace f -event (V.EvKey V.KLeft _) f = updateCursor (-1) f -event (V.EvKey V.KRight _) f = updateCursor 1 f -event (V.EvKey (V.KChar char) _) f = insertCharacter char f -event _ f = f - -updateCursor :: Int -> Field -> Field -updateCursor dir (Field text cursor) = Field text newCursor - where - next = cursor + dir - limit = length text - newCursor - | next <= 0 = 0 - | next > limit = limit - | otherwise = next - -backspace :: Field -> Field -backspace (Field text cursor) = - let (start, end) = T.splitAt cursor text - in case fromNullable start of - Nothing -> Field end cursor - Just start' -> Field (init start' <> end) (cursor - 1) - -insertCharacter :: Char -> Field -> Field -insertCharacter char (Field text cursor) = Field newText newCursor - where - (start, end) = T.splitAt cursor text - newText = snoc start char <> end - newCursor = cursor + 1 - -insertText :: Text -> Field -> Field -insertText insert (Field text cursor) = Field newText newCursor - where - (start, end) = T.splitAt cursor text - newText = concat [start, insert, end] - newCursor = cursor + length insert - -cursorPosition :: [Text] -> Int -> Int -> (Int, Int) -cursorPosition text width cursor = - if x == width - then (0, y + 1) - else (x, y) - where - scanned = L.scanl1 (+) $ length <$> text - below = takeWhile (< cursor) scanned - x = cursor - maybe 0 last (fromNullable below) - y = length below - -getText :: Field -> Text -getText (Field text _) = text - -textToField :: Text -> Field -textToField text = Field text (length text) - -field :: Field -> B.Widget UI.ResourceName -field (Field text cursor) = - B.Widget B.Fixed B.Fixed $ do - width <- B.availWidth <$> B.getContext - let (wrapped, offset) = wrap width text - location = cursorPosition wrapped width (cursor - offset) - B.render $ - if null text - then B.showCursor UI.RNCursor (B.Location (0, 0)) $ B.txt " " - else B.showCursor UI.RNCursor (B.Location location) . B.vBox $ B.txt <$> wrapped - -widgetFromMaybe :: B.Widget UI.ResourceName -> Maybe Field -> B.Widget UI.ResourceName -widgetFromMaybe _ (Just f) = field f -widgetFromMaybe w Nothing = w - -textField :: Text -> B.Widget UI.ResourceName -textField text = - B.Widget B.Fixed B.Fixed $ do - width <- B.availWidth <$> B.getContext - let (wrapped, _) = wrap width text - B.render $ - if null text - then B.txt "---" - else B.vBox $ B.txt <$> wrapped - --- wrap -wrap :: Int -> Text -> ([Text], Int) -wrap width = foldl' (combine width) ([""], 0) . spl - -spl' :: [Text] -> Char -> [Text] -spl' ts c - | c == ' ' = ts <> [" "] <> [""] - | otherwise = - case fromNullable ts of - Just ts' -> init ts' <> [snoc (last ts') c] - Nothing -> [singleton c] - -spl :: Text -> [Text] -spl = foldl' spl' [""] - -combine :: Int -> ([Text], Int) -> Text -> ([Text], Int) -combine width (acc, offset) s - | newline && s == " " = (acc, offset + 1) - | T.takeEnd 1 l == " " && s == " " = (acc, offset + 1) - | newline = (acc <> [s], offset) - | otherwise = (append (l <> s) acc, offset) - where - l = maybe "" last (fromNullable acc) - newline = B.textWidth l + B.textWidth s > width - -append :: Text -> [Text] -> [Text] -append s l = - case fromNullable l of - Just l' -> init l' <> [s] - Nothing -> l <> [s] diff --git a/src/UI/Modal.hs b/src/UI/Modal.hs deleted file mode 100644 --- a/src/UI/Modal.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module UI.Modal - ( showModal - ) where - -import ClassyPrelude - -import Control.Lens ((^.)) - -import Brick -import Brick.Widgets.Border -import Brick.Widgets.Center - -import Data.Taskell.Date (Day) -import Events.State.Types (State, mode) -import Events.State.Types.Mode (ModalType (..), Mode (..)) -import IO.Keyboard.Types (Bindings) -import UI.Field (textField) -import UI.Modal.Detail (detail) -import UI.Modal.Help (help) -import UI.Modal.MoveTo (moveTo) -import UI.Theme (titleAttr) -import UI.Types (ResourceName (..)) - -surround :: Int -> (Text, Widget ResourceName) -> Widget ResourceName -surround ht (title, widget) = - padTopBottom 1 . - centerLayer . - border . - padTopBottom 1 . - padLeftRight 4 . vLimit (ht - 9) . hLimit 50 . (t <=>) . viewport RNModal Vertical $ - widget - where - t = padBottom (Pad 1) . withAttr titleAttr $ textField title - -showModal :: Int -> Bindings -> State -> Day -> Widget ResourceName -showModal ht bindings state today = - case state ^. mode of - Modal Help -> surround ht (help bindings) - Modal Detail {} -> surround ht (detail state today) - Modal MoveTo -> surround ht (moveTo state) - _ -> emptyWidget diff --git a/src/UI/Modal/Detail.hs b/src/UI/Modal/Detail.hs deleted file mode 100644 --- a/src/UI/Modal/Detail.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module UI.Modal.Detail - ( detail - ) where - -import ClassyPrelude - -import Control.Lens ((^.)) - -import Data.Sequence (mapWithIndex) - -import Brick - -import Data.Taskell.Date (Day, dayToOutput, deadline) -import qualified Data.Taskell.Subtask as ST (Subtask, complete, name) -import Data.Taskell.Task (Task, description, due, name, subtasks) -import Events.State (getCurrentTask) -import Events.State.Modal.Detail (getCurrentItem, getField) -import Events.State.Types (State) -import Events.State.Types.Mode (DetailItem (..)) -import UI.Field (Field, textField, widgetFromMaybe) -import UI.Theme (disabledAttr, dlToAttr, taskCurrentAttr, - titleCurrentAttr) -import UI.Types (ResourceName (..)) - -renderSubtask :: Maybe Field -> DetailItem -> Int -> ST.Subtask -> Widget ResourceName -renderSubtask f current i subtask = padBottom (Pad 1) $ prefix <+> final - where - cur = - case current of - DetailItem c -> i == c - _ -> False - done = subtask ^. ST.complete - attr = - withAttr - (if cur - then taskCurrentAttr - else titleCurrentAttr) - prefix = - attr . txt $ - if done - then "[x] " - else "[ ] " - widget = textField (subtask ^. ST.name) - final - | cur = visible . attr $ widgetFromMaybe widget f - | not done = attr widget - | otherwise = widget - -renderSummary :: Maybe Field -> DetailItem -> Task -> Widget ResourceName -renderSummary f i task = padTop (Pad 1) $ padBottom (Pad 2) w' - where - w = textField $ fromMaybe "No description" (task ^. description) - w' = - case i of - DetailDescription -> visible $ widgetFromMaybe w f - _ -> w - -renderDate :: Day -> Maybe Field -> DetailItem -> Task -> Widget ResourceName -renderDate today field item task = - case item of - DetailDate -> visible $ prefix <+> widgetFromMaybe widget field - _ -> - case day of - Just d -> prefix <+> withAttr (dlToAttr (deadline today d)) widget - Nothing -> emptyWidget - where - day = task ^. due - prefix = txt "Due: " - widget = textField $ maybe "" dayToOutput day - -detail :: State -> Day -> (Text, Widget ResourceName) -detail state today = - fromMaybe ("Error", txt "Oops") $ do - task <- getCurrentTask state - i <- getCurrentItem state - let f = getField state - let sts = task ^. subtasks - w - | null sts = withAttr disabledAttr $ txt "No sub-tasks" - | otherwise = vBox . toList $ renderSubtask f i `mapWithIndex` sts - pure (task ^. name, renderDate today f i task <=> renderSummary f i task <=> w) diff --git a/src/UI/Modal/Help.hs b/src/UI/Modal/Help.hs deleted file mode 100644 --- a/src/UI/Modal/Help.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedStrings #-} - -module UI.Modal.Help - ( help - ) where - -import ClassyPrelude - -import Brick -import Data.Text as T (justifyRight) - -import Events.Actions.Types as A (ActionType (..)) -import IO.Keyboard.Types (Bindings, bindingsToText) - -import UI.Field (textField) -import UI.Theme (taskCurrentAttr) -import UI.Types (ResourceName) - -descriptions :: [([ActionType], Text)] -descriptions = - [ ([A.Help], "Show this list of controls") - , ([A.Previous, A.Next, A.Left, A.Right], "Move down / up / left / right") - , ([A.Bottom], "Go to bottom of list") - , ([A.New], "Add a task") - , ([A.NewAbove, A.NewBelow], "Add a task above / below") - , ([A.Edit], "Edit a task") - , ([A.Clear], "Change task") - , ([A.Detail], "Show task details / Edit task description") - , ([A.DueDate], "Add/edit due date (yyyy-mm-dd)") - , ([A.MoveUp, A.MoveDown], "Shift task down / up") - , ([A.MoveLeft, A.MoveRight], "Shift task left / right") - , ([A.MoveMenu], "Move task to specific list") - , ([A.Delete], "Delete task") - , ([A.Undo], "Undo") - , ([A.ListNew], "New list") - , ([A.ListEdit], "Edit list title") - , ([A.ListDelete], "Delete list") - , ([A.ListLeft, A.ListRight], "Move list left / right") - , ([A.Search], "Search") - , ([A.Quit], "Quit") - ] - -generate :: Bindings -> [([Text], Text)] -generate bindings = first (intercalate ", " . bindingsToText bindings <$>) <$> descriptions - -format :: ([Text], Text) -> (Text, Text) -format = first (intercalate " / ") - -line :: Int -> (Text, Text) -> Widget ResourceName -line m (l, r) = left <+> right - where - left = padRight (Pad 2) . withAttr taskCurrentAttr . txt $ justifyRight m ' ' l - right = textField r - -help :: Bindings -> (Text, Widget ResourceName) -help bindings = ("Controls", w) - where - ls = format <$> generate bindings - m = foldl' max 0 $ length . fst <$> ls - w = vBox $ line m <$> ls diff --git a/src/UI/Modal/MoveTo.hs b/src/UI/Modal/MoveTo.hs deleted file mode 100644 --- a/src/UI/Modal/MoveTo.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module UI.Modal.MoveTo - ( moveTo - ) where - -import ClassyPrelude - -import Control.Lens ((^.)) - -import Brick - -import Data.Taskell.List (title) -import Events.State (getCurrentList) -import Events.State.Types (State, lists) -import UI.Field (textField) -import UI.Theme (taskCurrentAttr) -import UI.Types (ResourceName) - -moveTo :: State -> (Text, Widget ResourceName) -moveTo state = ("Move To:", widget) - where - skip = getCurrentList state - ls = toList $ state ^. lists - titles = textField . (^. title) <$> ls - letter a = - padRight (Pad 1) . hBox $ [txt "[", withAttr taskCurrentAttr $ txt (singleton a), txt "]"] - letters = letter <$> ['a' ..] - remove i l = take i l <> drop (i + 1) l - output (l, t) = l <+> t - widget = vBox $ output <$> remove skip (zip letters titles) diff --git a/src/UI/Types.hs b/src/UI/Types.hs --- a/src/UI/Types.hs +++ b/src/UI/Types.hs @@ -4,13 +4,7 @@ import ClassyPrelude (Eq, Int, Ord, Show) -newtype ListIndex = ListIndex - { showListIndex :: Int - } deriving (Show, Eq, Ord) - -newtype TaskIndex = TaskIndex - { showTaskIndex :: Int - } deriving (Show, Eq, Ord) +import Types (ListIndex, TaskIndex) data ResourceName = RNCursor @@ -18,4 +12,5 @@ | RNList Int | RNLists | RNModal + | RNDue Int deriving (Show, Eq, Ord) diff --git a/taskell.cabal b/taskell.cabal --- a/taskell.cabal +++ b/taskell.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 name: taskell -version: 1.5.0.0 +version: 1.7.0.0 license: BSD3 license-file: LICENSE copyright: 2019 Mark Wales @@ -54,7 +54,8 @@ IO.Keyboard IO.Keyboard.Parser IO.Keyboard.Types - UI.Field + UI.Draw.Field + Types hs-source-dirs: src other-modules: Config @@ -62,11 +63,13 @@ Events.Actions.Insert Events.Actions.Modal Events.Actions.Modal.Detail + Events.Actions.Modal.Due Events.Actions.Modal.Help Events.Actions.Modal.MoveTo Events.Actions.Normal Events.Actions.Search Events.State.Modal.Detail + Events.State.Modal.Due IO.Config.General IO.Config.GitHub IO.Config.Layout @@ -81,18 +84,26 @@ IO.Markdown UI.CLI UI.Draw - UI.Modal - UI.Modal.Detail - UI.Modal.Help - UI.Modal.MoveTo + UI.Draw.Main + UI.Draw.Main.List + UI.Draw.Main.Search + UI.Draw.Main.StatusBar + UI.Draw.Modal + UI.Draw.Modal.Detail + UI.Draw.Modal.Due + UI.Draw.Modal.Help + UI.Draw.Modal.MoveTo + UI.Draw.Mode + UI.Draw.Task + UI.Draw.Types UI.Theme UI.Types Paths_taskell default-language: Haskell2010 default-extensions: OverloadedStrings NoImplicitPrelude build-depends: - aeson >=1.4.2.0 && <1.5, - attoparsec >=0.13.2.2 && <0.14, + aeson >=1.4.5.0 && <1.5, + attoparsec >=0.13.2.3 && <0.14, base >=4.12.0.0 && <=5, brick >=0.47.1 && <0.48, bytestring >=0.10.8.2 && <0.11, @@ -101,9 +112,9 @@ containers >=0.6.0.1 && <0.7, directory >=1.3.3.0 && <1.4, file-embed >=0.0.11 && <0.1, - fold-debounce >=0.2.0.8 && <0.3, - http-client >=0.5.14 && <0.6, - http-conduit >=2.3.7.1 && <2.4, + fold-debounce >=0.2.0.9 && <0.3, + http-client >=0.6.4 && <0.7, + http-conduit >=2.3.7.3 && <2.4, http-types >=0.12.3 && <0.13, lens >=4.17.1 && <4.18, mtl >=2.2.2 && <2.3, @@ -150,7 +161,7 @@ default-extensions: OverloadedStrings NoImplicitPrelude ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - aeson >=1.4.2.0 && <1.5, + aeson >=1.4.5.0 && <1.5, base >=4.12.0.0 && <4.13, classy-prelude >=1.5.0 && <1.6, containers >=0.6.0.1 && <0.7, @@ -158,10 +169,10 @@ lens >=4.17.1 && <4.18, raw-strings-qq ==1.1.*, taskell -any, - tasty ==1.2.*, + tasty >=1.2.3 && <1.3, tasty-discover >=4.2.1 && <4.3, - tasty-expected-failure >=0.11.1.1 && <0.12, - tasty-hunit >=0.10.0.1 && <0.11, + tasty-expected-failure >=0.11.1.2 && <0.12, + tasty-hunit >=0.10.0.2 && <0.11, text >=1.2.3.1 && <1.3, time >=1.8.0.2 && <1.9, vty >=5.25.1 && <5.26 diff --git a/templates/bindings.ini b/templates/bindings.ini --- a/templates/bindings.ini +++ b/templates/bindings.ini @@ -3,6 +3,7 @@ undo = u search = / help = ? +due = ! # navigation previous = k @@ -15,6 +16,7 @@ new = a newAbove = O newBelow = o +duplicate = + # editing tasks edit = e, A, i @@ -22,12 +24,14 @@ delete = D detail = dueDate = @ +clearDate = # moving tasks moveUp = K moveDown = J moveLeft = H -moveRight = L, +moveRight = L +complete = moveMenu = m # lists diff --git a/test/Data/Taskell/ListNavigationTest.hs b/test/Data/Taskell/ListNavigationTest.hs --- a/test/Data/Taskell/ListNavigationTest.hs +++ b/test/Data/Taskell/ListNavigationTest.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} module Data.Taskell.ListNavigationTest - ( test_list + ( test_listNav ) where import ClassyPrelude as CP @@ -28,8 +28,8 @@ list = List "Populated" taskSeq -- tests -test_list :: TestTree -test_list = +test_listNav :: TestTree +test_listNav = testGroup "Data.Taskell.List Navigation" [ testGroup @@ -74,5 +74,8 @@ , testCase "out of bounds with no term" (assertEqual "nothing" 5 (L.nearest 50 Nothing list)) + , testCase + "out of bounds by 1 with no term" + (assertEqual "nothing" 5 (L.nearest 6 Nothing list)) ] ] diff --git a/test/Data/Taskell/ListTest.hs b/test/Data/Taskell/ListTest.hs --- a/test/Data/Taskell/ListTest.hs +++ b/test/Data/Taskell/ListTest.hs @@ -92,37 +92,61 @@ (assertEqual "List with moved item" (Just - (List - "Populated" - (fromList [T.new "Hello", T.new "Fish", T.new "Blah"]))) - (move 1 1 populatedList)) + ( List + "Populated" + (fromList [T.new "Hello", T.new "Fish", T.new "Blah"]) + , 2)) + (move 1 1 Nothing populatedList)) , testCase "down" (assertEqual "List with moved item" (Just - (List - "Populated" - (fromList [T.new "Blah", T.new "Hello", T.new "Fish"]))) - (move 1 (-1) populatedList)) + ( List + "Populated" + (fromList [T.new "Blah", T.new "Hello", T.new "Fish"]) + , 0)) + (move 1 (-1) Nothing populatedList)) , testCase "up - out of bounds" (assertEqual "List with moved item" (Just - (List - "Populated" - (fromList [T.new "Hello", T.new "Fish", T.new "Blah"]))) - (move 1 10 populatedList)) + ( List + "Populated" + (fromList [T.new "Hello", T.new "Fish", T.new "Blah"]) + , 2)) + (move 1 10 Nothing populatedList)) , testCase "down - out of bounds" (assertEqual "List with moved item" (Just - (List - "Populated" - (fromList [T.new "Blah", T.new "Hello", T.new "Fish"]))) - (move 1 (-10) populatedList)) + ( List + "Populated" + (fromList [T.new "Blah", T.new "Hello", T.new "Fish"]) + , 0)) + (move 1 (-10) Nothing populatedList)) + , testCase + "up - with search" + (assertEqual + "List with moved item" + (Just + ( List + "Populated" + (fromList [T.new "Blah", T.new "Fish", T.new "Hello"]) + , 2)) + (move 0 1 (Just "Fish") populatedList)) + , testCase + "down - with search" + (assertEqual + "List with moved item" + (Just + ( List + "Populated" + (fromList [T.new "Fish", T.new "Hello", T.new "Blah"]) + , 0)) + (move 2 (-1) (Just "Hello") populatedList)) ] , testCase "deleteTask" diff --git a/test/Data/Taskell/ListsTest.hs b/test/Data/Taskell/ListsTest.hs --- a/test/Data/Taskell/ListsTest.hs +++ b/test/Data/Taskell/ListsTest.hs @@ -13,14 +13,27 @@ import qualified Data.Taskell.List as L import Data.Taskell.Lists.Internal import qualified Data.Taskell.Task as T +import Types (ListIndex (ListIndex), TaskIndex (TaskIndex)) -- test data list1, list2, list3 :: L.List -list1 = foldl' (flip L.append) (L.empty "List 1") [T.new "One", T.new "Two", T.new "Three"] +list1 = + foldl' + (flip L.append) + (L.empty "List 1") + [T.new "One", T.setDue "2019-08-14" (T.new "Two"), T.new "Three"] -list2 = foldl' (flip L.append) (L.empty "List 2") [T.new "1", T.new "2", T.new "3"] +list2 = + foldl' + (flip L.append) + (L.empty "List 2") + [T.new "1", T.new "2", T.setDue "2018-12-03" (T.new "3")] -list3 = foldl' (flip L.append) (L.empty "List 3") [T.new "01", T.new "10", T.new "11"] +list3 = + foldl' + (flip L.append) + (L.empty "List 3") + [T.setDue "2019-04-05" (T.new "01"), T.new "10", T.new "11"] testLists :: Lists testLists = fromList [list1, list2, list3] @@ -68,13 +81,17 @@ , foldl' (flip L.append) (L.empty "List 2") - [T.new "1", T.new "3"] + [T.new "1", T.setDue "2018-12-03" (T.new "3")] , foldl' (flip L.append) (L.empty "List 3") - [T.new "01", T.new "10", T.new "11", T.new "2"] + [ T.setDue "2019-04-05" (T.new "01") + , T.new "10" + , T.new "11" + , T.new "2" + ] ])) - (changeList (1, 1) testLists 1)) + (changeList (ListIndex 1, TaskIndex 1) testLists 1)) , testCase "left" (assertEqual @@ -84,20 +101,30 @@ [ foldl' (flip L.append) (L.empty "List 1") - [T.new "One", T.new "Two", T.new "Three", T.new "2"] + [ T.new "One" + , T.setDue "2019-08-14" (T.new "Two") + , T.new "Three" + , T.new "2" + ] , foldl' (flip L.append) (L.empty "List 2") - [T.new "1", T.new "3"] + [T.new "1", T.setDue "2018-12-03" (T.new "3")] , list3 ])) - (changeList (1, 1) testLists (-1))) + (changeList (ListIndex 1, TaskIndex 1) testLists (-1))) , testCase "out of bounds list" - (assertEqual "Nothing" Nothing (changeList (5, 1) testLists 1)) + (assertEqual + "Nothing" + Nothing + (changeList (ListIndex 5, TaskIndex 1) testLists 1)) , testCase "out of bounds task" - (assertEqual "Nothing" Nothing (changeList (1, 10) testLists 1)) + (assertEqual + "Nothing" + Nothing + (changeList (ListIndex 1, TaskIndex 10) testLists 1)) ] , testCase "newList" @@ -173,7 +200,11 @@ , foldl' (flip L.append) (L.empty "List 3") - [T.new "01", T.new "10", T.new "11", T.new "Blah"] + [ T.setDue "2019-04-05" (T.new "01") + , T.new "10" + , T.new "11" + , T.new "Blah" + ] ]) (appendToLast (T.new "Blah") testLists)) , testCase @@ -186,4 +217,14 @@ "Returns an analysis" "test.md\nLists: 3\nTasks: 9" (analyse "test.md" testLists)) + , testCase + "due" + (assertEqual + "returns just due list" + (fromList + [ ((ListIndex 1, TaskIndex 2), T.setDue "2018-12-03" (T.new "3")) + , ((ListIndex 2, TaskIndex 0), T.setDue "2019-04-05" (T.new "01")) + , ((ListIndex 0, TaskIndex 1), T.setDue "2019-08-14" (T.new "Two")) + ]) + (due testLists)) ] diff --git a/test/Events/StateTest.hs b/test/Events/StateTest.hs --- a/test/Events/StateTest.hs +++ b/test/Events/StateTest.hs @@ -12,24 +12,31 @@ import Control.Lens ((&), (.~), (^.)) +import Data.Time.Clock (secondsToDiffTime) + import qualified Data.Sequence as S (lookup) import qualified Data.Taskell.List as L (append, empty) import qualified Data.Taskell.Task as T (new) import Events.State import Events.State.Types import Events.State.Types.Mode +import Types (ListIndex (..), TaskIndex (..)) +mockTime :: UTCTime +mockTime = UTCTime (ModifiedJulianDay 20) (secondsToDiffTime 0) + testState :: State testState = State { _mode = Normal , _lists = empty , _history = [] - , _current = (0, 0) + , _current = (ListIndex 0, TaskIndex 0) , _path = "test.md" , _io = Nothing , _height = 0 , _searchTerm = Nothing + , _time = mockTime } moveToState :: State @@ -49,11 +56,12 @@ , L.empty "List 9" ] , _history = [] - , _current = (4, 0) + , _current = (ListIndex 4, TaskIndex 0) , _path = "test.md" , _io = Nothing , _height = 0 , _searchTerm = Nothing + , _time = mockTime } -- tests diff --git a/test/IO/Keyboard/ParserTest.hs b/test/IO/Keyboard/ParserTest.hs --- a/test/IO/Keyboard/ParserTest.hs +++ b/test/IO/Keyboard/ParserTest.hs @@ -44,6 +44,7 @@ , (BChar 'u', A.Undo) , (BChar '/', A.Search) , (BChar '?', A.Help) + , (BChar '!', A.Due) , (BChar 'k', A.Previous) , (BChar 'j', A.Next) , (BChar 'h', A.Left) @@ -52,6 +53,7 @@ , (BChar 'a', A.New) , (BChar 'O', A.NewAbove) , (BChar 'o', A.NewBelow) + , (BChar '+', A.Duplicate) , (BChar 'e', A.Edit) , (BChar 'A', A.Edit) , (BChar 'i', A.Edit) diff --git a/test/IO/Keyboard/TypesTest.hs b/test/IO/Keyboard/TypesTest.hs --- a/test/IO/Keyboard/TypesTest.hs +++ b/test/IO/Keyboard/TypesTest.hs @@ -22,6 +22,7 @@ [ (BChar 'œ', A.Quit) , (BChar 'U', A.Undo) , (BChar '/', A.Search) + , (BChar '!', A.Due) , (BChar '?', A.Help) , (BChar 'k', A.Previous) , (BChar 'j', A.Next) @@ -31,6 +32,7 @@ , (BChar 'a', A.New) , (BChar 'O', A.NewAbove) , (BChar 'o', A.NewBelow) + , (BChar '+', A.Duplicate) , (BChar 'e', A.Edit) , (BChar 'A', A.Edit) , (BChar 'i', A.Edit) @@ -38,11 +40,12 @@ , (BChar 'D', A.Delete) , (BKey "Enter", A.Detail) , (BChar '@', A.DueDate) + , (BKey "Backspace", A.ClearDate) , (BChar 'K', A.MoveUp) , (BChar 'J', A.MoveDown) , (BChar 'H', A.MoveLeft) , (BChar 'L', A.MoveRight) - , (BKey "Space", A.MoveRight) + , (BKey "Space", A.Complete) , (BChar 'm', A.MoveMenu) , (BChar 'N', A.ListNew) , (BChar 'E', A.ListEdit) diff --git a/test/IO/KeyboardTest.hs b/test/IO/KeyboardTest.hs --- a/test/IO/KeyboardTest.hs +++ b/test/IO/KeyboardTest.hs @@ -13,6 +13,8 @@ import Control.Lens ((.~)) +import Data.Time.Clock (secondsToDiffTime) + import Data.Taskell.Lists.Internal (initial) import Events.Actions.Types as A import Events.State (create, quit) @@ -22,11 +24,14 @@ import IO.Keyboard (generate) import IO.Keyboard.Types +mockTime :: UTCTime +mockTime = UTCTime (ModifiedJulianDay 20) (secondsToDiffTime 0) + tester :: BoundActions -> Event -> Stateful tester actions ev state = lookup ev actions >>= ($ state) cleanState :: State -cleanState = create "taskell.md" initial +cleanState = create mockTime "taskell.md" initial basicBindings :: Bindings basicBindings = [(BChar 'q', A.Quit)] diff --git a/test/IO/MarkdownTest.hs b/test/IO/MarkdownTest.hs --- a/test/IO/MarkdownTest.hs +++ b/test/IO/MarkdownTest.hs @@ -122,7 +122,7 @@ (assertEqual "List item with Sub-Task" (makeSubTask "Blah" True, []) - (start defaultConfig (listWithItem, []) (" * ~Blah~", 1))) + (start defaultConfig (listWithItem, []) (" * [x] Blah", 1))) , ignoreTest $ testCase "List item without list" @@ -194,12 +194,6 @@ "List item with Sub-Task" (makeSubTask "Blah" False, []) (start alternativeConfig (listWithItem, []) ("- Blah", 1))) - , testCase - "Complete Sub-Task (old style)" - (assertEqual - "List item with Sub-Task" - (makeSubTask "Blah" True, []) - (start alternativeConfig (listWithItem, []) ("- ~Blah~", 1))) ] ] , testGroup diff --git a/test/UI/FieldTest.hs b/test/UI/FieldTest.hs --- a/test/UI/FieldTest.hs +++ b/test/UI/FieldTest.hs @@ -7,8 +7,8 @@ import ClassyPrelude -import UI.Field (Field (Field), backspace, cursorPosition, insertCharacter, insertText, - updateCursor, wrap) +import UI.Draw.Field (Field (Field), backspace, cursorPosition, insertCharacter, insertText, + updateCursor, wrap) import Test.Tasty import Test.Tasty.HUnit @@ -24,7 +24,7 @@ test_field :: TestTree test_field = testGroup - "UI.Field" + "UI.Draw.Field" [ testGroup "Field cursor left" [ testCase @@ -148,10 +148,27 @@ (6, 1) (cursorPosition' "Artichoke penguin astronaut wombat" 34)) , testCase + "Triple line" + (assertEqual + "Should wrap to correct position" + (11, 2) + (cursorPosition' + "Artichoke penguin astronaut wombat artichoke penguin astronaut wombat" + 64)) + , testCase "Long words with space" (assertEqual "Should ignore the space when counting" (16, 1) (cursorPosition' "Blah fish wombat monkey sponge catpult arsonist" 47)) + , testCase + "Multibyte string single line" + (assertEqual "Should move in twos" (4, 0) (cursorPosition' "乤乭亍乫" 2)) + , testCase + "Multibyte string multi-line" + (assertEqual + "Should move in twos" + (4, 1) + (cursorPosition' "乤乭亍乫 乤乭亍乫 乤乭亍乫 乤乭亍乫" 17)) ] ]