taskell 1.4.0.0 → 1.5.0.0
raw patch · 37 files changed
+744/−356 lines, 37 filesdep ~brickdep ~http-conduitdep ~lens
Dependency ranges changed: brick, http-conduit, lens
Files
- README.md +8/−43
- src/App.hs +16/−8
- src/Config.hs +1/−1
- src/Data/Taskell/List.hs +3/−0
- src/Data/Taskell/List/Internal.hs +47/−2
- src/Data/Taskell/Task/Internal.hs +13/−8
- src/Events/Actions.hs +1/−1
- src/Events/Actions/Modal/Detail.hs +13/−11
- src/Events/Actions/Modal/Help.hs +4/−2
- src/Events/Actions/Normal.hs +31/−29
- src/Events/Actions/Search.hs +5/−19
- src/Events/Actions/Types.hs +70/−0
- src/Events/State.hs +45/−51
- src/Events/State/Types.hs +9/−6
- src/Events/State/Types/Mode.hs +1/−2
- src/IO/Config.hs +7/−2
- src/IO/Keyboard.hs +60/−2
- src/IO/Keyboard/Parser.hs +4/−3
- src/IO/Keyboard/Types.hs +14/−9
- src/IO/Taskell.hs +14/−35
- src/UI/CLI.hs +8/−2
- src/UI/Draw.hs +91/−32
- src/UI/Modal.hs +11/−9
- src/UI/Modal/Help.hs +23/−22
- src/UI/Theme.hs +8/−3
- taskell.cabal +8/−5
- templates/github-token.txt +1/−1
- templates/theme.ini +4/−0
- templates/trello-token.txt +1/−1
- test/Data/Taskell/ListNavigationTest.hs +78/−0
- test/Data/Taskell/ListTest.hs +9/−3
- test/Data/Taskell/TaskTest.hs +21/−6
- test/Events/StateTest.hs +4/−0
- test/IO/Keyboard/ParserTest.hs +36/−35
- test/IO/Keyboard/TypesTest.hs +71/−0
- test/IO/KeyboardTest.hs +3/−2
- test/Spec.hs +1/−1
README.md view
@@ -47,7 +47,7 @@ ### Debian/Ubuntu -[A `.deb` package is available for Debian/Ubuntu](https://github.com/smallhadroncollider/taskell/releases). Download it and install with `dpkg -i <package-name>`.+[A `.deb` package is available for Debian/Ubuntu](https://github.com/smallhadroncollider/taskell/releases). Download it and install with `dpkg -i <package-name>`. You may also need to install the `libtinfo5` package (`sudo apt install libtinfo5`). ### Fedora @@ -251,51 +251,12 @@ You can edit keyboard bindings in the `bindings.ini` config file. -The default bindings are as follows:--```ini-# general-quit = q-undo = u-search = /-help = ?--# navigation-previous = k-next = j-left = h-right = l-bottom = G--# new tasks-new = a-newAbove = O-newBelow = o--# editing tasks-edit = e, A, i-clear = C-delete = D-detail = <Enter>-dueDate = @--# moving tasks-moveUp = K-moveDown = J-moveLeft = H-moveRight = L, <Space>-moveMenu = m--# lists-listNew = N-listEdit = E-listDelete = X-listRight = >-listLeft = <-```+The default bindings can be found in [`bindings.ini`](https://github.com/smallhadroncollider/taskell/blob/master/templates/bindings.ini). Available special keys: `<Space>`, `<Enter>`, `<Backspace>`, `<Left>`, `<Right>`, `<Up>`, `<Down>` +On a Mac you can use the `alt` characters: e.g. `quit = œ` is equivalent to `alt+q`.+ You shouldn't try to assign the `1`-`9` keys, as it will not overwrite the default behaviour. @@ -308,6 +269,10 @@ ; list title title.fg = green++; status bar+statusBar.bg = magenta+statusBar.fg = black ; current list title titleCurrent.fg = blue
src/App.hs view
@@ -9,7 +9,8 @@ import Control.Lens ((^.)) import Brick-import Graphics.Vty (Mode (BracketedPaste), outputIface, setMode, supportsMode)+import Graphics.Vty (Mode (BracketedPaste), displayBounds, outputIface, setMode,+ supportsMode) import Graphics.Vty.Input.Events (Event (..)) import qualified Control.FoldDebounce as Debounce@@ -17,8 +18,8 @@ import Data.Taskell.Date (currentDay) import Data.Taskell.Lists (Lists) import Events.Actions (ActionSets, event, generateActions)-import Events.State (continue, countCurrent)-import Events.State.Types (State, current, io, lists, mode, path)+import Events.State (continue, countCurrent, setHeight)+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.Taskell (writeData)@@ -85,8 +86,8 @@ (DebouncedWrite, Trigger) -> ActionSets -> State -> Event -> EventM ResourceName (Next State) handleVtyEvent (send, trigger) actions previousState e = do let state = event actions e previousState+ when (previousState ^. searchTerm /= state ^. searchTerm) invalidateCache case previousState ^. mode of- Search _ _ -> invalidateCache (Modal MoveTo) -> clearAllTitles previousState (Insert ITask ICreate _) -> clearList previousState _ -> pure ()@@ -96,15 +97,21 @@ (Insert ITask ICreate _) -> clearList state *> next send state _ -> clearCache previousState *> clearCache state *> next send state +getHeight :: EventM ResourceName Int+getHeight = snd <$> (displayBounds =<< outputIface <$> getVtyHandle)+ handleEvent :: (DebouncedWrite, Trigger) -> ActionSets -> State -> BrickEvent ResourceName e -> EventM ResourceName (Next State)-handleEvent _ _ state (VtyEvent (EvResize _ _)) = invalidateCache *> Brick.continue state-handleEvent db actions state (VtyEvent ev) = handleVtyEvent db actions state ev-handleEvent _ _ state _ = Brick.continue state+handleEvent _ _ state (VtyEvent (EvResize _ _)) = do+ invalidateCache+ h <- getHeight+ Brick.continue (setHeight h state)+handleEvent db actions state (VtyEvent ev) = handleVtyEvent db actions state ev+handleEvent _ _ state _ = Brick.continue state -- | Runs when the app starts -- Adds paste support@@ -112,7 +119,8 @@ appStart state = do output <- outputIface <$> getVtyHandle when (supportsMode output BracketedPaste) . liftIO $ setMode output BracketedPaste True- pure state+ h <- getHeight+ pure (setHeight h state) -- | Sets up Brick go :: Config -> State -> IO ()
src/Config.hs view
@@ -9,7 +9,7 @@ import Data.FileEmbed (embedFile) version :: Text-version = "1.4.0"+version = "1.5.0" usage :: Text usage = decodeUtf8 $(embedFile "templates/usage.txt")
src/Data/Taskell/List.hs view
@@ -17,6 +17,9 @@ , deleteTask , getTask , searchFor+ , nextTask+ , prevTask+ , nearest ) where import Data.Taskell.List.Internal
src/Data/Taskell/List/Internal.hs view
@@ -5,7 +5,7 @@ import ClassyPrelude -import Control.Lens (ix, makeLenses, (%%~), (%~), (&), (.~), (^.), (^?))+import Control.Lens (element, makeLenses, (%%~), (%~), (&), (.~), (^.), (^?)) import Data.Sequence as S (adjust', deleteAt, insertAt, update, (|>)) @@ -59,7 +59,52 @@ deleteTask idx = tasks %~ deleteAt idx getTask :: Int -> List -> Maybe T.Task-getTask idx = (^? tasks . ix idx)+getTask idx = (^? tasks . element idx) searchFor :: Text -> Update searchFor text = tasks %~ filter (T.contains text)++changeTask :: Int -> Int -> Maybe Text -> List -> Maybe Int+changeTask dir current term list = do+ let next = current + dir+ tsk <- getTask next list+ case term of+ Nothing -> Just next+ Just trm ->+ if T.contains trm tsk+ then Just next+ else changeTask dir next term list++nextTask :: Int -> Maybe Text -> List -> Int+nextTask idx text lst = fromMaybe idx $ changeTask 1 idx text lst++prevTask :: Int -> Maybe Text -> List -> Int+prevTask idx text lst = fromMaybe idx $ changeTask (-1) idx text lst++closest :: Int -> Int -> Int -> Int+closest current previous next =+ if (next - current) < (current - previous)+ then next+ else previous++bound :: Int -> List -> Int+bound idx lst+ | idx < 0 = 0+ | idx > count lst = count lst - 1+ | otherwise = idx++nearest' :: Int -> Maybe Text -> List -> Maybe Int+nearest' current term lst = do+ let prev = changeTask (-1) current term lst+ let nxt = changeTask 1 current term lst+ let comp idx = Just $ maybe idx (closest current idx) nxt+ maybe nxt comp prev++nearest :: Int -> Maybe Text -> List -> Int+nearest current term lst = idx+ where+ near = fromMaybe (-1) $ nearest' current term lst+ idx =+ case term of+ Nothing -> bound current lst+ Just txt -> maybe near (bool near current . T.contains txt) $ getTask current lst
src/Data/Taskell/Task/Internal.hs view
@@ -34,9 +34,10 @@ setDescription :: Text -> Update setDescription text =+ description .~ if null (strip text)- then id- else description .~ Just text+ then Nothing+ else Just text maybeAppend :: Text -> Maybe Text -> Maybe Text maybeAppend text (Just current) = Just (concat [current, "\n", text])@@ -49,10 +50,12 @@ else description %~ maybeAppend text setDue :: Text -> Update-setDue date =- case textToDay date of- Just day -> due .~ Just day- Nothing -> id+setDue date task =+ if null date+ then task & due .~ Nothing+ else case textToDay date of+ Just day -> task & due .~ Just day+ Nothing -> task getSubtask :: Int -> Task -> Maybe ST.Subtask getSubtask idx = (^? subtasks . ix idx)@@ -76,9 +79,11 @@ countCompleteSubtasks = length . filter (^. ST.complete) . (^. subtasks) contains :: Text -> Task -> Bool-contains text task = text `isInfixOf` (task ^. name) || not (null sts)+contains text task =+ check (task ^. name) || maybe False check (task ^. description) || not (null sts) where- sts = filter (isInfixOf text) $ (^. ST.name) <$> (task ^. subtasks)+ check = isInfixOf (toLower text) . toLower+ sts = filter check $ (^. ST.name) <$> (task ^. subtasks) isBlank :: Task -> Bool isBlank task =
src/Events/Actions.hs view
@@ -31,7 +31,7 @@ event' e state = case state ^. mode of Normal -> Normal.event e state- Search {} -> Search.event e state+ Search -> Search.event e state Insert {} -> Insert.event e state Modal {} -> Modal.event e state _ -> pure state
src/Events/Actions/Modal/Detail.hs view
@@ -9,27 +9,29 @@ import ClassyPrelude +import Events.Actions.Types as A (ActionType (..)) import Events.State import Events.State.Modal.Detail as Detail import Events.State.Types import Events.State.Types.Mode (DetailItem (..), DetailMode (..)) import Graphics.Vty.Input.Events+import IO.Keyboard.Types (Actions) import qualified UI.Field as F (event) -events :: Map Text Stateful+events :: Actions events -- general =- [ ("quit", quit)- , ("undo", (write =<<) . undo)- , ("previous", previousSubtask)- , ("next", nextSubtask)- , ("new", (Detail.insertMode =<<) . (Detail.lastSubtask =<<) . (Detail.newItem =<<) . store)- , ("edit", (Detail.insertMode =<<) . store)- , ("moveRight", (write =<<) . (setComplete =<<) . store)- , ("delete", (write =<<) . (Detail.remove =<<) . store)- , ("dueDate", (editDue =<<) . store)- , ("detail", (editDescription =<<) . store)+ [ (A.Quit, quit)+ , (A.Undo, (write =<<) . undo)+ , (A.Previous, previousSubtask)+ , (A.Next, nextSubtask)+ , (A.New, (Detail.insertMode =<<) . (Detail.lastSubtask =<<) . (Detail.newItem =<<) . store)+ , (A.Edit, (Detail.insertMode =<<) . store)+ , (A.MoveRight, (write =<<) . (setComplete =<<) . store)+ , (A.Delete, (write =<<) . (Detail.remove =<<) . store)+ , (A.DueDate, (editDue =<<) . store)+ , (A.Detail, (editDescription =<<) . store) ] normal :: Event -> Stateful
src/Events/Actions/Modal/Help.hs view
@@ -8,12 +8,14 @@ ) where import ClassyPrelude+import Events.Actions.Types as A (ActionType (..)) import Events.State import Events.State.Types (Stateful) import Graphics.Vty.Input.Events+import IO.Keyboard.Types (Actions) -events :: Map Text Stateful-events = [("quit", quit)]+events :: Actions+events = [(A.Quit, quit)] event :: Event -> Stateful event (EvKey _ _) = normalMode
src/Events/Actions/Normal.hs view
@@ -9,48 +9,49 @@ import ClassyPrelude hiding (delete) import Data.Char (isDigit)-import Data.Map.Strict (Map)+import Events.Actions.Types as A (ActionType (..)) import Events.State import Events.State.Modal.Detail (editDue, showDetail) import Events.State.Types (Stateful) import Graphics.Vty.Input.Events+import IO.Keyboard.Types (Actions) -events :: Map Text Stateful+events :: Actions events -- general =- [ ("quit", quit)- , ("undo", (write =<<) . undo)- , ("search", searchMode)- , ("help", showHelp)+ [ (A.Quit, quit)+ , (A.Undo, (write =<<) . undo)+ , (A.Search, searchMode)+ , (A.Help, showHelp) -- navigation- , ("previous", previous)- , ("next", next)- , ("left", left)- , ("right", right)- , ("bottom", bottom)+ , (A.Previous, previous)+ , (A.Next, next)+ , (A.Left, left)+ , (A.Right, right)+ , (A.Bottom, bottom) -- new tasks- , ("new", (startCreate =<<) . (newItem =<<) . store)- , ("newAbove", (startCreate =<<) . (above =<<) . store)- , ("newBelow", (startCreate =<<) . (below =<<) . store)+ , (A.New, (startCreate =<<) . (newItem =<<) . store)+ , (A.NewAbove, (startCreate =<<) . (above =<<) . store)+ , (A.NewBelow, (startCreate =<<) . (below =<<) . store) -- editing tasks- , ("edit", (startEdit =<<) . store)- , ("clear", (startEdit =<<) . (clearItem =<<) . store)- , ("delete", (write =<<) . (delete =<<) . store)- , ("detail", showDetail)- , ("dueDate", (editDue =<<) . (store =<<) . showDetail)+ , (A.Edit, (startEdit =<<) . store)+ , (A.Clear, (startEdit =<<) . (clearItem =<<) . store)+ , (A.Delete, (write =<<) . (delete =<<) . store)+ , (A.Detail, showDetail)+ , (A.DueDate, (editDue =<<) . (store =<<) . showDetail) -- moving tasks- , ("moveUp", (write =<<) . (up =<<) . store)- , ("moveDown", (write =<<) . (down =<<) . store)- , ("moveLeft", (write =<<) . (bottom =<<) . (left =<<) . (moveLeft =<<) . store)- , ("moveRight", (write =<<) . (bottom =<<) . (right =<<) . (moveRight =<<) . store)- , ("moveMenu", showMoveTo)+ , (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.MoveMenu, showMoveTo) -- lists- , ("listNew", (createListStart =<<) . store)- , ("listEdit", (editListStart =<<) . store)- , ("listDelete", (write =<<) . (deleteCurrentList =<<) . store)- , ("listRight", (write =<<) . (listRight =<<) . store)- , ("listLeft", (write =<<) . (listLeft =<<) . store)+ , (A.ListNew, (createListStart =<<) . store)+ , (A.ListEdit, (editListStart =<<) . store)+ , (A.ListDelete, (write =<<) . (deleteCurrentList =<<) . store)+ , (A.ListRight, (write =<<) . (listRight =<<) . store)+ , (A.ListLeft, (write =<<) . (listLeft =<<) . store) ] -- Normal@@ -59,5 +60,6 @@ event (EvKey (KChar n) _) | isDigit n = selectList n | otherwise = pure+event (EvKey KEsc _) = clearSearch -- fallback event _ = pure
src/Events/Actions/Search.hs view
@@ -6,7 +6,7 @@ import ClassyPrelude -import Control.Lens ((&), (.~), (^.))+import Control.Lens ((^.)) import Events.State import Events.State.Types (Stateful, mode)@@ -14,24 +14,10 @@ import Graphics.Vty.Input.Events import qualified UI.Field as F (event) -import qualified Events.Actions.Normal as Normal--search :: Event -> Stateful-search (EvKey KEnter _) s = searchEntered s-search e s =- pure $- case s ^. mode of- Search ent field -> s & mode .~ Search ent (F.event e field)- _ -> s- event :: Event -> Stateful-event (EvKey KEsc _) s = normalMode s+event (EvKey KEsc _) s = clearSearch =<< normalMode s+event (EvKey KEnter _) s = normalMode s event e s = case s ^. mode of- Search ent _ ->- (if ent- then search- else Normal.event)- e- s- _ -> pure s+ Search -> appendSearch (F.event e) s+ _ -> pure s
+ src/Events/Actions/Types.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++module Events.Actions.Types where++import ClassyPrelude hiding (Left, Nothing, Right)++data ActionType+ = Quit+ | Undo+ | Search+ | Help+ | Previous+ | Next+ | Left+ | Right+ | Bottom+ | New+ | NewAbove+ | NewBelow+ | Edit+ | Clear+ | Delete+ | Detail+ | DueDate+ | MoveUp+ | MoveDown+ | MoveLeft+ | MoveRight+ | MoveMenu+ | ListNew+ | ListEdit+ | ListDelete+ | ListRight+ | ListLeft+ | Nothing+ deriving (Show, Eq, Ord, Enum)++allActions :: [ActionType]+allActions = [toEnum 0 ..]++read :: Text -> ActionType+read "quit" = Quit+read "undo" = Undo+read "search" = Search+read "help" = Help+read "previous" = Previous+read "next" = Next+read "left" = Left+read "right" = Right+read "bottom" = Bottom+read "new" = New+read "newAbove" = NewAbove+read "newBelow" = NewBelow+read "edit" = Edit+read "clear" = Clear+read "delete" = Delete+read "detail" = Detail+read "dueDate" = DueDate+read "moveUp" = MoveUp+read "moveDown" = MoveDown+read "moveLeft" = MoveLeft+read "moveRight" = MoveRight+read "moveMenu" = MoveMenu+read "listNew" = ListNew+read "listEdit" = ListEdit+read "listDelete" = ListDelete+read "listRight" = ListRight+read "listLeft" = ListLeft+read _ = Nothing
src/Events/State.hs view
@@ -6,6 +6,7 @@ ( continue , write , countCurrent+ , setHeight -- UI.Main , normalise -- Main@@ -36,8 +37,8 @@ , undo , store , searchMode- -- Events.Actions.Search- , searchEntered+ , clearSearch+ , appendSearch -- Events.Actions.Insert , createList , removeBlank@@ -60,19 +61,29 @@ import Data.Char (digitToInt, ord) -import Data.Taskell.List (List, deleteTask, getTask, move, new, newAt, title, update)+import Data.Taskell.List (List, deleteTask, getTask, move, nearest, new, newAt, nextTask,+ prevTask, title, update) import qualified Data.Taskell.Lists as Lists import Data.Taskell.Task (Task, isBlank, name) import Events.State.Types import Events.State.Types.Mode (InsertMode (..), InsertType (..), ModalType (..), Mode (..))-import UI.Field (blankField, getText, textToField)+import UI.Field (Field, blankField, getText, textToField) type InternalStateful = State -> State create :: FilePath -> Lists.Lists -> State create p ls =- State {_mode = Normal, _lists = ls, _history = [], _current = (0, 0), _path = p, _io = Nothing}+ State+ { _mode = Normal+ , _lists = ls+ , _history = []+ , _current = (0, 0)+ , _path = p+ , _io = Nothing+ , _height = 0+ , _searchTerm = Nothing+ } -- app state quit :: Stateful@@ -231,24 +242,18 @@ getIndex :: State -> Int getIndex = snd . (^. current) +changeTask :: (Int -> Maybe Text -> 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)+ next :: Stateful-next state = Just $ setIndex state idx'- where- idx = getIndex state- count = countCurrent state- idx' =- if idx < (count - 1)- then succ idx- else idx+next = changeTask nextTask previous :: Stateful-previous state = Just $ setIndex state idx'- where- idx = getIndex state- idx' =- if idx > 0- then pred idx- else 0+previous = changeTask prevTask left :: Stateful left state =@@ -271,21 +276,12 @@ fixIndex :: InternalStateful fixIndex state =- if getIndex state' > count- then setIndex state' count'- else state'+ case getList state of+ Just list -> setIndex state (nearest idx trm list)+ Nothing -> state where- lists' = state ^. lists- idx = Lists.exists (getCurrentList state) lists'- state' =- if idx- then state- else setCurrentList state (length lists' - 1)- count = countCurrent state' - 1- count' =- if count < 0- then 0- else count+ trm = getText <$> state ^. searchTerm+ idx = getIndex state -- tasks getCurrentList :: State -> Int@@ -332,18 +328,18 @@ -- search searchMode :: Stateful-searchMode state =- Just $- case state ^. mode of- Search _ field -> state & mode .~ Search True field- _ -> state & mode .~ Search True blankField+searchMode state = pure . fixIndex $ (state & mode .~ Search) & searchTerm .~ sTerm+ where+ sTerm = Just (fromMaybe blankField (state ^. searchTerm)) -searchEntered :: Stateful-searchEntered state =- case state ^. mode of- Search _ field -> Just $ state & mode .~ Search False field- _ -> Nothing+clearSearch :: Stateful+clearSearch state = pure $ state & searchTerm .~ Nothing +appendSearch :: (Field -> Field) -> Stateful+appendSearch genField state = do+ let field = fromMaybe blankField (state ^. searchTerm)+ pure . fixIndex $ state & searchTerm .~ Just (genField field)+ -- help showHelp :: Stateful showHelp = Just . (mode .~ Modal Help)@@ -351,13 +347,11 @@ showMoveTo :: Stateful showMoveTo = Just . (mode .~ Modal MoveTo) --- view - maybe shouldn't be in here...-search :: State -> State-search state =- case state ^. mode of- Search _ field -> fixIndex . setLists state $ Lists.search (getText field) (state ^. lists)- _ -> state+-- view+setHeight :: Int -> State -> State+setHeight i = height .~ i +-- more view - maybe shouldn't be in here... newList :: State -> State newList state = case state ^. mode of@@ -367,4 +361,4 @@ _ -> state normalise :: State -> State-normalise = newList . search+normalise = newList
src/Events/State/Types.hs view
@@ -8,18 +8,21 @@ import Control.Lens (makeLenses) import Data.Taskell.Lists (Lists)+import UI.Field (Field) import qualified Events.State.Types.Mode as M (Mode) type Pointer = (Int, Int) data State = State- { _mode :: M.Mode- , _lists :: Lists- , _history :: [(Pointer, Lists)]- , _current :: Pointer- , _path :: FilePath- , _io :: Maybe Lists+ { _mode :: M.Mode+ , _lists :: Lists+ , _history :: [(Pointer, Lists)]+ , _current :: Pointer+ , _path :: FilePath+ , _io :: Maybe Lists+ , _height :: Int+ , _searchTerm :: Maybe Field } deriving (Eq, Show) -- create lenses
src/Events/State/Types/Mode.hs view
@@ -40,7 +40,6 @@ InsertMode Field | Modal ModalType- | Search Bool- Field+ | Search | Shutdown deriving (Eq, Show)
src/IO/Config.hs view
@@ -7,7 +7,6 @@ import ClassyPrelude -import Data.Either (fromRight) import qualified Data.Text.IO as T (readFile) import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getHomeDirectory)@@ -18,6 +17,7 @@ import Data.FileEmbed (embedFile) import Data.Ini.Config +import IO.Keyboard (addMissing, badMapping, defaultBindings) import IO.Keyboard.Parser (bindings) import IO.Keyboard.Types (Bindings) import UI.Theme (defaultTheme)@@ -99,7 +99,12 @@ Left s -> putStrLn (pack $ "config.ini: " <> s) $> defaultConfig getBindings :: IO Bindings-getBindings = fromRight [] . bindings <$> (T.readFile =<< (bindingsPath <$> getDir))+getBindings = do+ bnds <- bindings <$> (T.readFile =<< (bindingsPath <$> getDir))+ case addMissing <$> (badMapping =<< bnds) of+ Right b -> pure b+ Left err ->+ putStrLn ("bindings.ini: " <> err <> " - using default bindings") $> defaultBindings -- generate theme generateAttrMap :: IO AttrMap
src/IO/Keyboard.hs view
@@ -1,15 +1,73 @@ {-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-} module IO.Keyboard ( generate+ , defaultBindings+ , badMapping+ , addMissing ) where -import ClassyPrelude+import ClassyPrelude hiding ((\\)) import Data.Bitraversable (bitraverse)+import Data.List ((\\)) -import IO.Keyboard.Types+import qualified Events.Actions.Types as A+import IO.Keyboard.Types generate :: Bindings -> Actions -> BoundActions generate bindings actions = mapFromList . catMaybes $ bitraverse bindingToEvent (`lookup` actions) <$> bindings++badMapping :: Bindings -> Either Text Bindings+badMapping bindings =+ if null result+ then Right bindings+ else Left "invalid mapping"+ where+ result = filter ((== A.Nothing) . snd) bindings++addMissing :: Bindings -> Bindings+addMissing bindings = bindings <> replaced+ where+ bnd = A.Nothing : (snd <$> bindings)+ result = A.allActions \\ bnd+ replaced = concat $ replace <$> result++replace :: A.ActionType -> Bindings+replace action = filter ((==) action . snd) defaultBindings++defaultBindings :: Bindings+defaultBindings =+ [ (BChar 'q', A.Quit)+ , (BChar 'u', A.Undo)+ , (BChar '/', A.Search)+ , (BChar '?', A.Help)+ , (BChar 'k', A.Previous)+ , (BChar 'j', A.Next)+ , (BChar 'h', A.Left)+ , (BChar 'l', A.Right)+ , (BChar 'g', A.Bottom)+ , (BChar 'a', A.New)+ , (BChar 'O', A.NewAbove)+ , (BChar 'o', A.NewBelow)+ , (BChar 'e', A.Edit)+ , (BChar 'A', A.Edit)+ , (BChar 'i', A.Edit)+ , (BChar 'C', A.Clear)+ , (BChar 'D', A.Delete)+ , (BKey "Enter", A.Detail)+ , (BChar '@', A.DueDate)+ , (BChar 'K', A.MoveUp)+ , (BChar 'J', A.MoveDown)+ , (BChar 'H', A.MoveLeft)+ , (BChar 'L', A.MoveRight)+ , (BKey "Space", A.MoveRight)+ , (BChar 'm', A.MoveMenu)+ , (BChar 'N', A.ListNew)+ , (BChar 'E', A.ListEdit)+ , (BChar 'X', A.ListDelete)+ , (BChar '>', A.ListRight)+ , (BChar '<', A.ListLeft)+ ]
src/IO/Keyboard/Parser.hs view
@@ -8,6 +8,7 @@ import Data.Attoparsec.Text +import Events.Actions.Types (ActionType, read) import IO.Keyboard.Types -- utility functions@@ -15,7 +16,7 @@ lexeme p = skipSpace *> p <* skipSpace commentP :: Parser ()-commentP = lexeme $ skipMany (char '#' *> manyTill anyChar endOfLine)+commentP = lexeme $ skipMany ((char '#' <|> char ';') *> manyTill anyChar endOfLine) stripComments :: Parser a -> Parser a stripComments p = lexeme $ commentP *> p <* commentP@@ -33,10 +34,10 @@ bindingP :: Parser [Binding] bindingP = lexeme $ (keyP <|> charP) `sepBy` char ',' -line :: Parser [(Binding, Text)]+line :: Parser [(Binding, ActionType)] line = stripComments $ do- name <- word+ name <- read <$> word _ <- lexeme $ char '=' binds <- bindingP pure $ (, name) <$> binds
src/IO/Keyboard/Types.hs view
@@ -8,25 +8,30 @@ import Data.Map.Strict (Map) import Graphics.Vty.Input.Events (Event (..), Key (..)) -import Events.State.Types (Stateful)+import qualified Events.Actions.Types as A (ActionType)+import Events.State.Types (Stateful) data Binding = BChar Char | BKey Text- deriving (Eq, Ord, Show)+ deriving (Eq, Ord) -type Bindings = [(Binding, Text)]+type Bindings = [(Binding, A.ActionType)] -type Actions = Map Text Stateful+type Actions = Map A.ActionType Stateful type BoundActions = Map Event Stateful -bindingToText :: Binding -> Text-bindingToText (BChar c) = singleton c-bindingToText (BKey name) = "<" <> name <> ">"+instance Show Binding where+ show (BChar c) = singleton c+ show (BKey "Up") = "↑"+ show (BKey "Down") = "↓"+ show (BKey "Left") = "←"+ show (BKey "Right") = "→"+ show (BKey name) = "<" <> unpack name <> ">" -bindingsToText :: Bindings -> Text -> [Text]-bindingsToText bindings key = bindingToText . fst <$> toList (filterMap (== key) bindings)+bindingsToText :: Bindings -> A.ActionType -> [Text]+bindingsToText bindings key = tshow . fst <$> toList (filterMap (== key) bindings) bindingToEvent :: Binding -> Maybe Event bindingToEvent (BChar char) = pure $ EvKey (KChar char) []
src/IO/Taskell.hs view
@@ -22,7 +22,7 @@ import qualified IO.HTTP.GitHub as GitHub (GitHubIdentifier, getLists) import qualified IO.HTTP.Trello as Trello (TrelloBoardID, getLists) -import UI.CLI (promptYN)+import UI.CLI (PromptYN (PromptYes), promptYN) type ReaderConfig a = ReaderT Config IO a @@ -45,17 +45,15 @@ load :: ReaderConfig Next load = getArgs >>= parseArgs +colonic :: FilePath -> Text -> Text+colonic path = ((pack path <> ": ") <>)+ loadFile :: Text -> ReaderConfig Next loadFile filepath = do mPath <- exists filepath case mPath of- Nothing -> pure Exit- Just path -> do- content <- readData path- pure $- case content of- Right lists -> Load path lists- Left err -> Output $ pack path <> ": " <> err+ Nothing -> pure Exit+ Just path -> either (Output . colonic path) (Load path) <$> readData path loadRemote :: (token -> FilePath -> ReaderConfig Next) -> token -> Text -> ReaderConfig Next loadRemote createFn identifier filepath = do@@ -76,12 +74,7 @@ let path = unpack filepath exists' <- fileExists path if exists'- then do- content <- readData path- pure $- case content of- Right lists -> Output $ analyse filepath lists- Left err -> Output $ pack path <> ": " <> err+ then Output . either (colonic path) (analyse filepath) <$> readData path else pure Exit createRemote ::@@ -93,20 +86,15 @@ -> ReaderConfig Next createRemote tokenFn missingToken getFn identifier path = do config <- ask- let maybeToken = tokenFn config- case maybeToken of+ case tokenFn config of Nothing -> pure $ Output missingToken Just token -> do lists <- lift $ runReaderT (getFn identifier) token case lists of Left txt -> pure $ Output txt- Right ls -> do- create <- promptCreate path- if create- then do- lift $ writeData config ls path- pure $ Load path ls- else pure Exit+ Right ls ->+ promptCreate path >>=+ bool (pure Exit) (Load path ls <$ lift (writeData config ls path)) createTrello :: Trello.TrelloBoardID -> FilePath -> ReaderConfig Next createTrello =@@ -128,13 +116,7 @@ exists' <- fileExists path if exists' then pure $ Just path- else do- create <- promptCreate path- if create- then do- createPath path- pure $ Just path- else pure Nothing+ else promptCreate path >>= bool (pure Nothing) (Just path <$ createPath path) fileExists :: FilePath -> ReaderConfig Bool fileExists path = lift $ doesFileExist path@@ -142,7 +124,7 @@ promptCreate :: FilePath -> ReaderConfig Bool promptCreate path = do cwd <- lift $ pack <$> getCurrentDirectory- lift $ promptYN $ concat ["Create ", cwd, "/", pack path, "?"]+ lift $ promptYN PromptYes $ concat ["Create ", cwd, "/", pack path, "?"] -- creates taskell file createPath :: FilePath -> ReaderConfig ()@@ -156,7 +138,4 @@ -- reads json file readData :: FilePath -> ReaderConfig (Either Text Lists)-readData path = do- config <- ask- content <- readFile path- pure $ parse config content+readData path = parse <$> ask <*> readFile path
src/UI/CLI.hs view
@@ -4,6 +4,7 @@ module UI.CLI ( prompt , promptYN+ , PromptYN(PromptYes) ) where import ClassyPrelude@@ -14,5 +15,10 @@ hFlush stdout -- prevents buffering getLine -promptYN :: Text -> IO Bool-promptYN s = (==) "y" <$> prompt (s <> " (y/n)")+data PromptYN+ = PromptYes+ | PromptNo++promptYN :: PromptYN -> Text -> IO Bool+promptYN PromptYes s = not . flip elem ["n", "no"] . toLower <$> prompt (s <> " (Y/n)")+promptYN PromptNo s = not . flip elem ["y", "yes"] . toLower <$> prompt (s <> " (y/N)")
src/UI/Draw.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-} module UI.Draw ( draw@@ -18,16 +19,17 @@ import Data.Taskell.Date (Day, dayToText, deadline) import Data.Taskell.List (List, tasks, title)-import Data.Taskell.Lists (Lists)-import qualified Data.Taskell.Task as T (Task, countCompleteSubtasks, countSubtasks,+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, lists, mode)+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, textField, widgetFromMaybe)+import UI.Field (Field, field, getText, textField, widgetFromMaybe) import UI.Modal (showModal) import UI.Theme import UI.Types (ListIndex (..), ResourceName (..), TaskIndex (..))@@ -37,10 +39,12 @@ { 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@@ -73,8 +77,8 @@ ] -- | Renders an individual task-renderTask :: Int -> Int -> T.Task -> ReaderDrawState (Widget ResourceName)-renderTask listIndex taskIndex task = do+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@@ -98,6 +102,16 @@ 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@@ -164,26 +178,68 @@ -- | Renders the search area renderSearch :: Widget ResourceName -> ReaderDrawState (Widget ResourceName) renderSearch mainWidget = do- m <- dsMode <$> ask- case m of- Search editing searchField -> do+ m <- asks dsMode+ term <- asks dsSearchTerm+ case term of+ Just searchField -> do colPad <- columnPadding . dsLayout <$> ask let attr = withAttr $- if editing- then taskCurrentAttr- else taskAttr- let widget = attr . padTopBottom 1 . padLeftRight colPad $ txt "/" <+> field searchField+ 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- renderSearch mainWidget+ statusBar <- renderStatusBar+ renderSearch (mainWidget <=> statusBar) getField :: Mode -> Maybe Field getField (Insert _ _ f) = Just f@@ -198,33 +254,36 @@ moveTo _ = False -- 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]+ draw :: Config -> Bindings -> Day -> State -> [Widget ResourceName]-draw layout bindings today state =- showModal- bindings- normalisedState- today- [ runReader- main- DrawState- { dsLists = normalisedState ^. lists- , dsMode = stateMode- , dsLayout = layout- , dsToday = today- , dsField = getField stateMode- , dsCurrent = normalisedState ^. current- , dsEditingTitle = editingTitle stateMode- }- ]+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+ } -- cursors chooseCursor :: State -> [CursorLocation ResourceName] -> Maybe (CursorLocation ResourceName) chooseCursor state = case normalise state ^. mode of Insert {} -> showCursorNamed RNCursor- Search True _ -> showCursorNamed RNCursor+ Search -> showCursorNamed RNCursor Modal (Detail _ (DetailInsert _)) -> showCursorNamed RNCursor _ -> neverShowCursor state
src/UI/Modal.hs view
@@ -23,19 +23,21 @@ import UI.Theme (titleAttr) import UI.Types (ResourceName (..)) -surround :: (Text, Widget ResourceName) -> Widget ResourceName-surround (title, widget) =+surround :: Int -> (Text, Widget ResourceName) -> Widget ResourceName+surround ht (title, widget) = padTopBottom 1 . centerLayer .- border . padTopBottom 1 . padLeftRight 4 . hLimit 50 . (t <=>) . viewport RNModal Vertical $+ 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 :: Bindings -> State -> Day -> [Widget ResourceName] -> [Widget ResourceName]-showModal bindings state today view =+showModal :: Int -> Bindings -> State -> Day -> Widget ResourceName+showModal ht bindings state today = case state ^. mode of- Modal Help -> surround (help bindings) : view- Modal Detail {} -> surround (detail state today) : view- Modal MoveTo -> surround (moveTo state) : view- _ -> view+ Modal Help -> surround ht (help bindings)+ Modal Detail {} -> surround ht (detail state today)+ Modal MoveTo -> surround ht (moveTo state)+ _ -> emptyWidget
src/UI/Modal/Help.hs view
@@ -11,34 +11,35 @@ import Brick import Data.Text as T (justifyRight) -import IO.Keyboard.Types (Bindings, bindingsToText)+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 :: [([Text], Text)]+descriptions :: [([ActionType], Text)] descriptions =- [ (["help"], "Show this list of controls")- , (["previous", "next", "left", "right"], "Move down/up/left/right")- , (["bottom"], "Go to bottom of list")- , (["new"], "Add a task")- , (["newAbove", "newBelow"], "Add a task above/below")- , (["edit"], "Edit a task")- , (["clear"], "Change task")- , (["detail"], "Show task details / Edit task description")- , (["dueDate"], "Add/edit due date (yyyy-mm-dd)")- , (["moveUp", "moveDown"], "Shift task down/up")- , (["moveLeft", "moveRight"], "Shift task left/right")- , (["moveMenu"], "Move task to specific list")- , (["delete"], "Delete task")- , (["undo"], "Undo")- , (["listNew"], "New list")- , (["listEdit"], "Edit list title")- , (["listDelete"], "Delete list")- , (["listLeft", "listRight"], "Move list left/right")- , (["search"], "Search")- , (["quit"], "Quit")+ [ ([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)]
src/UI/Theme.hs view
@@ -2,6 +2,7 @@ module UI.Theme ( titleAttr+ , statusBarAttr , titleCurrentAttr , taskCurrentAttr , taskAttr@@ -12,12 +13,15 @@ import Brick (AttrName, attrName) import Brick.Themes (Theme, newTheme)-import Brick.Util (fg)-import Graphics.Vty (blue, defAttr, green, magenta, red, yellow)+import Brick.Util (fg, on)+import Graphics.Vty import Data.Taskell.Date (Deadline (..)) -- attrs+statusBarAttr :: AttrName+statusBarAttr = attrName "statusBar"+ titleAttr :: AttrName titleAttr = attrName "title" @@ -55,7 +59,8 @@ defaultTheme = newTheme defAttr- [ (titleAttr, fg green)+ [ (statusBarAttr, black `on` green)+ , (titleAttr, fg green) , (titleCurrentAttr, fg blue) , (taskCurrentAttr, fg magenta) , (disabledAttr, fg yellow)
taskell.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.12 name: taskell-version: 1.4.0.0+version: 1.5.0.0 license: BSD3 license-file: LICENSE copyright: 2019 Mark Wales@@ -43,6 +43,7 @@ Data.Taskell.Subtask.Internal Data.Taskell.Task Data.Taskell.Task.Internal+ Events.Actions.Types Events.State.Types Events.State.Types.Mode IO.Config.Markdown@@ -93,7 +94,7 @@ aeson >=1.4.2.0 && <1.5, attoparsec >=0.13.2.2 && <0.14, base >=4.12.0.0 && <=5,- brick ==0.47.*,+ brick >=0.47.1 && <0.48, bytestring >=0.10.8.2 && <0.11, classy-prelude >=1.5.0 && <1.6, config-ini >=0.2.4.0 && <0.3,@@ -102,9 +103,9 @@ 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.6.1 && <2.4,+ http-conduit >=2.3.7.1 && <2.4, http-types >=0.12.3 && <0.13,- lens ==4.17.*,+ lens >=4.17.1 && <4.18, mtl >=2.2.2 && <2.3, template-haskell >=2.14.0.0 && <2.15, text >=1.2.3.1 && <1.3,@@ -130,6 +131,7 @@ hs-source-dirs: test other-modules: Data.Taskell.DateTest+ Data.Taskell.ListNavigationTest Data.Taskell.ListsTest Data.Taskell.ListTest Data.Taskell.SeqTest@@ -138,6 +140,7 @@ Events.StateTest IO.GitHubTest IO.Keyboard.ParserTest+ IO.Keyboard.TypesTest IO.KeyboardTest IO.MarkdownTest IO.TrelloTest@@ -152,7 +155,7 @@ classy-prelude >=1.5.0 && <1.6, containers >=0.6.0.1 && <0.7, file-embed >=0.0.11 && <0.1,- lens ==4.17.*,+ lens >=4.17.1 && <4.18, raw-strings-qq ==1.1.*, taskell -any, tasty ==1.2.*,
templates/github-token.txt view
@@ -4,7 +4,7 @@ Make sure to tick the "repo" scope. -When you have your personal access token, add it to ~/.taskell/config.ini:+When you have your personal access token, add it to ~/.config/taskell/config.ini: [github] token = <your-github-personal-access-token>
templates/theme.ini view
@@ -3,6 +3,10 @@ ; list title title.fg = green +; status bar+statusBar.bg = blue+statusBar.fg = black+ ; current list title titleCurrent.fg = blue
templates/trello-token.txt view
@@ -2,7 +2,7 @@ https://trello.com/1/authorize?expiration=never&name=taskell&scope=read&response_type=token&key=80dbcf6f88f62cc5639774e13342c20b -When you have your access token, add it to ~/.taskell/config.ini:+When you have your access token, add it to ~/.config/taskell/config.ini: [trello] token = <your-trello-access-token>
@@ -0,0 +1,78 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Taskell.ListNavigationTest+ ( test_list+ ) where++import ClassyPrelude as CP++import Test.Tasty+import Test.Tasty.HUnit++import Data.Taskell.List.Internal as L+import qualified Data.Taskell.Task as T (Task, new)++taskSeq :: Seq T.Task+taskSeq =+ fromList+ [ T.new "Hello"+ , T.new "Blah"+ , T.new "Fish"+ , T.new "Spoons"+ , T.new "Hello Again!"+ , T.new "Computers"+ ]++list :: List+list = List "Populated" taskSeq++-- tests+test_list :: TestTree+test_list =+ testGroup+ "Data.Taskell.List Navigation"+ [ testGroup+ "next"+ [ testCase "no term" (assertEqual "1" 1 (L.nextTask 0 Nothing list))+ , testCase "with term" (assertEqual "4" 4 (L.nextTask 0 (Just "Hello") list))+ , testCase+ "with term - no match"+ (assertEqual "0" 0 (L.nextTask 0 (Just "Wombat") list))+ ]+ , testGroup+ "prev"+ [ testCase "no term" (assertEqual "0" 0 (L.prevTask 1 Nothing list))+ , testCase "with term" (assertEqual "0" 0 (L.prevTask 4 (Just "Hello") list))+ , testCase+ "with term - no match"+ (assertEqual "4" 4 (L.prevTask 4 (Just "Wombat") list))+ ]+ , testGroup+ "nearest"+ [ testCase "no term" (assertEqual "same task" 2 (L.nearest 2 Nothing list))+ , testCase "term matches" (assertEqual "same task" 2 (L.nearest 2 (Just "ish") list))+ , testCase "term after" (assertEqual "next task" 3 (L.nearest 2 (Just "oons") list))+ , testCase+ "term before"+ (assertEqual "previous task" 3 (L.nearest 5 (Just "oons") list))+ , testCase+ "term both - before closer"+ (assertEqual "previous task" 0 (L.nearest 2 (Just "Hello") list))+ , testCase+ "term both - after closer"+ (assertEqual "next task" 4 (L.nearest 3 (Just "Hello") list))+ , testCase+ "no matches"+ (assertEqual "nothing" (-1) (L.nearest 3 (Just "Penguins") list))+ , testCase+ "nothing to match"+ (assertEqual "nothing" 3 (L.nearest (-1) (Just "Spoon") list))+ , testCase+ "nothing with no term"+ (assertEqual "nothing" 0 (L.nearest (-1) Nothing list))+ , testCase+ "out of bounds with no term"+ (assertEqual "nothing" 5 (L.nearest 50 Nothing list))+ ]+ ]
test/Data/Taskell/ListTest.hs view
@@ -148,9 +148,15 @@ , testCase "multiple" (assertEqual- "Blah and Fish"- (List "Populated" (fromList [T.new "Blah", T.new "Fish"]))- (searchFor "h" populatedList))+ "Hello and Blah"+ (List "Populated" (fromList [T.new "Hello", T.new "Blah"]))+ (searchFor "l" populatedList))+ , testCase+ "case-insensitive"+ (assertEqual+ "Hello"+ (List "Populated" (fromList [T.new "Hello"]))+ (searchFor "hello" populatedList)) , testCase "doesn't exist" (assertEqual
test/Data/Taskell/TaskTest.hs view
@@ -17,11 +17,14 @@ import qualified Data.Taskell.Subtask as ST (name, new) import Data.Taskell.Task.Internal +desc :: Maybe Text+desc = Just "A very boring description"+ testTask :: Task testTask = Task { _name = "Test"- , _description = Nothing+ , _description = desc , _subtasks = fromList [ST.new "One" True, ST.new "Two" False, ST.new "Three" False] , _due = Nothing }@@ -76,7 +79,7 @@ "Returns the task with added subtask" (Task "Test"- Nothing+ desc (fromList [ ST.new "One" True , ST.new "Two" False@@ -107,7 +110,7 @@ "Returns updated task" (Task "Test"- Nothing+ desc (fromList [ST.new "One" True, ST.new "Cow" False, ST.new "Three" False]) Nothing)@@ -118,7 +121,7 @@ "Returns task" (Task "Test"- Nothing+ desc (fromList [ST.new "One" True, ST.new "Two" False, ST.new "Three" False]) Nothing)@@ -132,7 +135,7 @@ "Returns updated task" (Task "Test"- Nothing+ desc (fromList [ST.new "One" True, ST.new "Three" False]) Nothing) (removeSubtask 1 testTask))@@ -142,7 +145,7 @@ "Returns task" (Task "Test"- Nothing+ desc (fromList [ST.new "One" True, ST.new "Two" False, ST.new "Three" False]) Nothing)@@ -156,7 +159,19 @@ "contains" [ testCase "in task" (assertEqual "Finds in task" True (contains "Test" testTask)) , testCase "in sub-task" (assertEqual "Find sub-task" True (contains "One" testTask))+ , testCase+ "case-insensitive"+ (assertEqual "Find sub-task" True (contains "ONE" testTask))+ , testCase+ "case-insensitive"+ (assertEqual "Find sub-task" True (contains "two" testTask)) , testCase "missing" (assertEqual "Find sub-task" False (contains "Fish" testTask))+ , testCase+ "description"+ (assertEqual "Finds in description" True (contains "boring" testTask))+ , testCase+ "not in description"+ (assertEqual "Doesn't find" False (contains "escapades" testTask)) ] , testGroup "isBlank"
test/Events/StateTest.hs view
@@ -28,6 +28,8 @@ , _current = (0, 0) , _path = "test.md" , _io = Nothing+ , _height = 0+ , _searchTerm = Nothing } moveToState :: State@@ -50,6 +52,8 @@ , _current = (4, 0) , _path = "test.md" , _io = Nothing+ , _height = 0+ , _searchTerm = Nothing } -- tests
test/IO/Keyboard/ParserTest.hs view
@@ -15,14 +15,15 @@ import Data.FileEmbed (embedFile) import Text.RawString.QQ (r) -import IO.Keyboard.Parser (bindings)-import IO.Keyboard.Types+import qualified Events.Actions.Types as A+import IO.Keyboard.Parser (bindings)+import IO.Keyboard.Types basic :: Text basic = "quit = q" basicResult :: Bindings-basicResult = [(BChar 'q', "quit")]+basicResult = [(BChar 'q', A.Quit)] basicMulti :: Text basicMulti =@@ -32,50 +33,50 @@ |] basicMultiResult :: Bindings-basicMultiResult = [(BChar 'q', "quit"), (BKey "Enter", "detail")]+basicMultiResult = [(BChar 'q', A.Quit), (BKey "Enter", A.Detail)] ini :: Text ini = decodeUtf8 $(embedFile "test/IO/Keyboard/data/bindings.ini") iniResult :: Bindings iniResult =- [ (BChar 'q', "quit")- , (BChar 'u', "undo")- , (BChar '/', "search")- , (BChar '?', "help")- , (BChar 'k', "previous")- , (BChar 'j', "next")- , (BChar 'h', "left")- , (BChar 'l', "right")- , (BChar 'g', "bottom")- , (BChar 'a', "new")- , (BChar 'O', "newAbove")- , (BChar 'o', "newBelow")- , (BChar 'e', "edit")- , (BChar 'A', "edit")- , (BChar 'i', "edit")- , (BChar 'C', "clear")- , (BChar 'D', "delete")- , (BKey "Enter", "detail")- , (BChar '@', "dueDate")- , (BChar 'K', "moveUp")- , (BChar 'J', "moveDown")- , (BChar 'H', "moveLeft")- , (BChar 'L', "moveRight")- , (BKey "Space", "moveRight")- , (BChar 'm', "moveMenu")- , (BChar 'N', "listNew")- , (BChar 'E', "listEdit")- , (BChar 'X', "listDelete")- , (BChar '>', "listRight")- , (BChar '<', "listLeft")+ [ (BChar 'q', A.Quit)+ , (BChar 'u', A.Undo)+ , (BChar '/', A.Search)+ , (BChar '?', A.Help)+ , (BChar 'k', A.Previous)+ , (BChar 'j', A.Next)+ , (BChar 'h', A.Left)+ , (BChar 'l', A.Right)+ , (BChar 'g', A.Bottom)+ , (BChar 'a', A.New)+ , (BChar 'O', A.NewAbove)+ , (BChar 'o', A.NewBelow)+ , (BChar 'e', A.Edit)+ , (BChar 'A', A.Edit)+ , (BChar 'i', A.Edit)+ , (BChar 'C', A.Clear)+ , (BChar 'D', A.Delete)+ , (BKey "Enter", A.Detail)+ , (BChar '@', A.DueDate)+ , (BChar 'K', A.MoveUp)+ , (BChar 'J', A.MoveDown)+ , (BChar 'H', A.MoveLeft)+ , (BChar 'L', A.MoveRight)+ , (BKey "Space", A.MoveRight)+ , (BChar 'm', A.MoveMenu)+ , (BChar 'N', A.ListNew)+ , (BChar 'E', A.ListEdit)+ , (BChar 'X', A.ListDelete)+ , (BChar '>', A.ListRight)+ , (BChar '<', A.ListLeft) ] comma :: Text comma = "quit = ," commaResult :: Bindings-commaResult = [(BChar ',', "quit")]+commaResult = [(BChar ',', A.Quit)] test_parser :: TestTree test_parser =
+ test/IO/Keyboard/TypesTest.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++module IO.Keyboard.TypesTest+ ( test_types+ ) where++import ClassyPrelude++import Test.Tasty+import Test.Tasty.HUnit++import qualified Events.Actions.Types as A (ActionType (..))+import IO.Keyboard (addMissing, badMapping, defaultBindings)+import IO.Keyboard.Types (Binding (..), Bindings)++notFull :: Bindings+notFull = [(BChar 'œ', A.Quit), (BChar 'U', A.Undo)]++notFullResult :: Bindings+notFullResult =+ [ (BChar 'œ', A.Quit)+ , (BChar 'U', A.Undo)+ , (BChar '/', A.Search)+ , (BChar '?', A.Help)+ , (BChar 'k', A.Previous)+ , (BChar 'j', A.Next)+ , (BChar 'h', A.Left)+ , (BChar 'l', A.Right)+ , (BChar 'g', A.Bottom)+ , (BChar 'a', A.New)+ , (BChar 'O', A.NewAbove)+ , (BChar 'o', A.NewBelow)+ , (BChar 'e', A.Edit)+ , (BChar 'A', A.Edit)+ , (BChar 'i', A.Edit)+ , (BChar 'C', A.Clear)+ , (BChar 'D', A.Delete)+ , (BKey "Enter", A.Detail)+ , (BChar '@', A.DueDate)+ , (BChar 'K', A.MoveUp)+ , (BChar 'J', A.MoveDown)+ , (BChar 'H', A.MoveLeft)+ , (BChar 'L', A.MoveRight)+ , (BKey "Space", A.MoveRight)+ , (BChar 'm', A.MoveMenu)+ , (BChar 'N', A.ListNew)+ , (BChar 'E', A.ListEdit)+ , (BChar 'X', A.ListDelete)+ , (BChar '>', A.ListRight)+ , (BChar '<', A.ListLeft)+ ]++bad :: Bindings+bad = [(BChar 'q', A.Quit), (BChar 'u', A.Nothing), (BChar '>', A.Nothing), (BChar '<', A.ListLeft)]++-- tests+test_types :: TestTree+test_types =+ testGroup+ "Events.Actions.Types"+ [ testCase+ "not missing"+ (assertEqual "Finds no missing items" defaultBindings (addMissing defaultBindings))+ , testCase+ "not missing"+ (assertEqual "Finds missing items" notFullResult (addMissing notFull))+ , testCase+ "bad mapping"+ (assertEqual "Finds bad mapping" (Left "invalid mapping") (badMapping bad))+ ]
test/IO/KeyboardTest.hs view
@@ -14,6 +14,7 @@ import Control.Lens ((.~)) import Data.Taskell.Lists.Internal (initial)+import Events.Actions.Types as A import Events.State (create, quit) import Events.State.Types (State, Stateful, mode) import Events.State.Types.Mode (Mode (Shutdown))@@ -28,10 +29,10 @@ cleanState = create "taskell.md" initial basicBindings :: Bindings-basicBindings = [(BChar 'q', "quit")]+basicBindings = [(BChar 'q', A.Quit)] basicActions :: Actions-basicActions = [("quit", quit)]+basicActions = [(A.Quit, quit)] basicResult :: Maybe State basicResult = Just $ (mode .~ Shutdown) cleanState
test/Spec.hs view
@@ -1,1 +1,1 @@-{-# OPTIONS_GHC -F -pgmF tasty-discover #-}+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --hide-successes #-}