taskell 1.3.6.0 → 1.4.0.0
raw patch · 22 files changed
+593/−192 lines, 22 filesdep +attoparsecdep +raw-strings-qqdep ~aesondep ~basedep ~brick
Dependencies added: attoparsec, raw-strings-qq
Dependency ranges changed: aeson, base, brick, classy-prelude, config-ini, containers, directory, file-embed, http-conduit, http-types, lens, tasty, template-haskell, vty
Files
- README.md +53/−5
- src/App.hs +21/−19
- src/Config.hs +1/−1
- src/Events/Actions.hs +38/−7
- src/Events/Actions/Modal/Detail.hs +20/−12
- src/Events/Actions/Modal/Help.hs +8/−3
- src/Events/Actions/Normal.hs +41/−41
- src/IO/Config.hs +34/−31
- src/IO/HTTP/GitHub.hs +1/−3
- src/IO/HTTP/Trello.hs +4/−5
- src/IO/Keyboard.hs +15/−0
- src/IO/Keyboard/Parser.hs +49/−0
- src/IO/Keyboard/Types.hs +40/−0
- src/UI/Draw.hs +6/−4
- src/UI/Modal.hs +4/−3
- src/UI/Modal/Help.hs +39/−9
- src/UI/Types.hs +9/−1
- taskell.cabal +33/−25
- templates/bindings.ini +38/−0
- templates/controls.md +0/−23
- test/IO/Keyboard/ParserTest.hs +90/−0
- test/IO/KeyboardTest.hs +49/−0
README.md view
@@ -25,11 +25,11 @@ - [Installation](#installation) - [Using Taskell](#using-taskell) - [Options](#options)- - [Controls](#controls) - [Storage](#storage) - [Importing Trello Boards](#importing-trello-boards) - [Importing GitHub Projects](#importing-github-projects) - [Configuration](#configuration)+ - [Controls](#controls) - [Theming](#theming) - [Roadmap](#roadmap) @@ -83,10 +83,6 @@ - `-t <trello-board-id>`: import a Trello board ([see below](#importing-trello-boards)) - `-g <github-project-id>`: import a GitHub project ([see below](#importing-github-projects)) -### Controls--Press `?` for a [list of controls](https://github.com/smallhadroncollider/taskell/blob/master/templates/controls.md)- #### Tips - If you're using a simple two-column "To Do" and "Done" then use the space bar to mark an item as complete while staying in the "To Do" list. If you're using a more complicated column setup then you will want to use `H`/`L` to move tasks between columns.@@ -250,6 +246,58 @@ ``` **Warning**: currently if you change your `[markdown]` settings any older files stored with different settings will not be readable.++### Controls++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 = <+```++Available special keys: `<Space>`, `<Enter>`, `<Backspace>`, `<Left>`, `<Right>`, `<Up>`, `<Down>`++You shouldn't try to assign the `1`-`9` keys, as it will not overwrite the default behaviour.+ ### Theming
src/App.hs view
@@ -16,14 +16,14 @@ import Data.Taskell.Date (currentDay) import Data.Taskell.Lists (Lists)-import Events.Actions (event)+import Events.Actions (ActionSets, event, generateActions) import Events.State (continue, countCurrent) import Events.State.Types (State, current, io, lists, mode, path) import Events.State.Types.Mode (InsertMode (..), InsertType (..), ModalType (..), Mode (..))-import IO.Config (Config, generateAttrMap, layout)+import IO.Config (Config, generateAttrMap, getBindings, layout) import IO.Taskell (writeData) import UI.Draw (chooseCursor, draw)-import UI.Types (ResourceName (..))+import UI.Types (ListIndex (..), ResourceName (..), TaskIndex (..)) type DebouncedMessage = (Lists, FilePath) @@ -51,7 +51,7 @@ Debounce.new Debounce.Args { Debounce.cb = store config- , Debounce.fold = \_ b -> b+ , Debounce.fold = flip const , Debounce.init = (initial ^. lists, initial ^. path) } Debounce.def@@ -63,14 +63,14 @@ clearCache state = do let (li, ti) = state ^. current invalidateCacheEntry (RNList li)- invalidateCacheEntry (RNTask (li, ti))+ invalidateCacheEntry (RNTask (ListIndex li, TaskIndex ti)) clearAllTitles :: State -> EventM ResourceName () clearAllTitles state = do let count = length (state ^. lists) let range = [0 .. (count - 1)]- void . sequence $ invalidateCacheEntry . RNList <$> range- void . sequence $ invalidateCacheEntry . (\x -> RNTask (x, -1)) <$> range+ traverse_ (invalidateCacheEntry . RNList) range+ traverse_ (invalidateCacheEntry . RNTask . flip (,) (TaskIndex (-1)) . ListIndex) range clearList :: State -> EventM ResourceName () clearList state = do@@ -78,12 +78,13 @@ let count = countCurrent state let range = [0 .. (count - 1)] invalidateCacheEntry $ RNList list- void . sequence $ invalidateCacheEntry . (\x -> RNTask (list, x)) <$> range+ traverse_ (invalidateCacheEntry . RNTask . (,) (ListIndex list) . TaskIndex) range -- event handling-handleVtyEvent :: (DebouncedWrite, Trigger) -> State -> Event -> EventM ResourceName (Next State)-handleVtyEvent (send, trigger) previousState e = do- let state = event e previousState+handleVtyEvent ::+ (DebouncedWrite, Trigger) -> ActionSets -> State -> Event -> EventM ResourceName (Next State)+handleVtyEvent (send, trigger) actions previousState e = do+ let state = event actions e previousState case previousState ^. mode of Search _ _ -> invalidateCache (Modal MoveTo) -> clearAllTitles previousState@@ -97,20 +98,20 @@ handleEvent :: (DebouncedWrite, Trigger)+ -> ActionSets -> State -> BrickEvent ResourceName e -> EventM ResourceName (Next State)-handleEvent _ state (VtyEvent (EvResize _ _)) = invalidateCache *> Brick.continue state-handleEvent db state (VtyEvent ev) = handleVtyEvent db state ev-handleEvent _ state _ = Brick.continue 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 -- | Runs when the app starts -- Adds paste support appStart :: State -> EventM ResourceName State appStart state = do- vty <- getVtyHandle- let output = outputIface vty- when (supportsMode output BracketedPaste) $ liftIO $ setMode output BracketedPaste True+ output <- outputIface <$> getVtyHandle+ when (supportsMode output BracketedPaste) . liftIO $ setMode output BracketedPaste True pure state -- | Sets up Brick@@ -119,11 +120,12 @@ attrMap' <- const <$> generateAttrMap today <- currentDay db <- debounce config initial+ bindings <- getBindings let app = App- { appDraw = draw (layout config) today+ { appDraw = draw (layout config) bindings today , appChooseCursor = chooseCursor- , appHandleEvent = handleEvent db+ , appHandleEvent = handleEvent db (generateActions bindings) , appStartEvent = appStart , appAttrMap = attrMap' }
src/Config.hs view
@@ -9,7 +9,7 @@ import Data.FileEmbed (embedFile) version :: Text-version = "1.3.6"+version = "1.4.0" usage :: Text usage = decodeUtf8 $(embedFile "templates/usage.txt")
src/Events/Actions.hs view
@@ -2,6 +2,8 @@ module Events.Actions ( event+ , generateActions+ , ActionSets ) where import ClassyPrelude@@ -11,13 +13,18 @@ import Graphics.Vty.Input.Events (Event (..)) import Events.State.Types (State, Stateful, mode)-import Events.State.Types.Mode (Mode (..))+import Events.State.Types.Mode (DetailMode (..), ModalType (..), Mode (..)) -import qualified Events.Actions.Insert as Insert-import qualified Events.Actions.Modal as Modal-import qualified Events.Actions.Normal as Normal-import qualified Events.Actions.Search as Search+import IO.Keyboard (generate)+import IO.Keyboard.Types (Bindings, BoundActions) +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.Help as Help+import qualified Events.Actions.Normal as Normal+import qualified Events.Actions.Search as Search+ -- takes an event and returns a Maybe State event' :: Event -> Stateful -- for other events pass through to relevant modules@@ -30,5 +37,29 @@ _ -> pure state -- returns new state if successful-event :: Event -> State -> State-event e state = fromMaybe state $ event' e state+event :: ActionSets -> Event -> State -> State+event actions e state = do+ let mEv =+ case state ^. mode of+ Normal -> lookup e $ normal actions+ Modal (Detail _ DetailNormal) -> lookup e $ detail actions+ Modal Help -> lookup e $ help actions+ _ -> Nothing+ fromMaybe state $+ case mEv of+ Nothing -> event' e state+ Just ev -> ev state++data ActionSets = ActionSets+ { normal :: BoundActions+ , detail :: BoundActions+ , help :: BoundActions+ }++generateActions :: Bindings -> ActionSets+generateActions bindings =+ ActionSets+ { normal = generate bindings Normal.events+ , detail = generate bindings Detail.events+ , help = generate bindings Help.events+ }
src/Events/Actions/Modal/Detail.hs view
@@ -1,7 +1,10 @@ {-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-} module Events.Actions.Modal.Detail ( event+ , events ) where import ClassyPrelude@@ -13,20 +16,25 @@ import Graphics.Vty.Input.Events import qualified UI.Field as F (event) +events :: Map Text Stateful+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)+ ]+ normal :: Event -> Stateful-normal (EvKey (KChar 'q') _) = quit normal (EvKey KEsc _) = normalMode-normal (EvKey KEnter _) = (editDescription =<<) . store-normal (EvKey (KChar ' ') _) = (write =<<) . (setComplete =<<) . store-normal (EvKey (KChar 'k') _) = previousSubtask-normal (EvKey (KChar 'j') _) = nextSubtask-normal (EvKey (KChar 'a') _) =- (Detail.insertMode =<<) . (Detail.lastSubtask =<<) . (Detail.newItem =<<) . store-normal (EvKey (KChar 'e') _) = (Detail.insertMode =<<) . store-normal (EvKey (KChar 'D') _) = (write =<<) . (Detail.remove =<<) . store-normal (EvKey (KChar 'u') _) = (write =<<) . undo-normal (EvKey (KChar '@') _) = (editDue =<<) . store-normal _ = pure+normal _ = pure insert :: Event -> Stateful insert (EvKey KEsc _) s = do
src/Events/Actions/Modal/Help.hs view
@@ -1,7 +1,10 @@ {-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-} module Events.Actions.Modal.Help ( event+ , events ) where import ClassyPrelude@@ -9,7 +12,9 @@ import Events.State.Types (Stateful) import Graphics.Vty.Input.Events +events :: Map Text Stateful+events = [("quit", quit)]+ event :: Event -> Stateful-event (EvKey (KChar 'q') _) = quit-event (EvKey _ _) = normalMode-event _ = pure+event (EvKey _ _) = normalMode+event _ = pure
src/Events/Actions/Normal.hs view
@@ -1,60 +1,60 @@ {-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedLists #-} module Events.Actions.Normal ( event+ , events ) where import ClassyPrelude hiding (delete) import Data.Char (isDigit)+import Data.Map.Strict (Map) import Events.State import Events.State.Modal.Detail (editDue, showDetail) import Events.State.Types (Stateful) import Graphics.Vty.Input.Events +events :: Map Text Stateful+events+ -- general+ =+ [ ("quit", quit)+ , ("undo", (write =<<) . undo)+ , ("search", searchMode)+ , ("help", showHelp)+ -- navigation+ , ("previous", previous)+ , ("next", next)+ , ("left", left)+ , ("right", right)+ , ("bottom", bottom)+ -- new tasks+ , ("new", (startCreate =<<) . (newItem =<<) . store)+ , ("newAbove", (startCreate =<<) . (above =<<) . store)+ , ("newBelow", (startCreate =<<) . (below =<<) . store)+ -- editing tasks+ , ("edit", (startEdit =<<) . store)+ , ("clear", (startEdit =<<) . (clearItem =<<) . store)+ , ("delete", (write =<<) . (delete =<<) . store)+ , ("detail", showDetail)+ , ("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)+ -- lists+ , ("listNew", (createListStart =<<) . store)+ , ("listEdit", (editListStart =<<) . store)+ , ("listDelete", (write =<<) . (deleteCurrentList =<<) . store)+ , ("listRight", (write =<<) . (listRight =<<) . store)+ , ("listLeft", (write =<<) . (listLeft =<<) . store)+ ]+ -- Normal event :: Event -> Stateful--- quit-event (EvKey (KChar 'q') _) = quit--- add/edit-event (EvKey (KChar 'e') _) = (startEdit =<<) . store-event (EvKey (KChar 'A') _) = (startEdit =<<) . store-event (EvKey (KChar 'i') _) = (startEdit =<<) . store-event (EvKey (KChar 'C') _) = (startEdit =<<) . (clearItem =<<) . store-event (EvKey (KChar 'a') _) = (startCreate =<<) . (newItem =<<) . store-event (EvKey (KChar 'O') _) = (startCreate =<<) . (above =<<) . store-event (EvKey (KChar 'o') _) = (startCreate =<<) . (below =<<) . store--- add list-event (EvKey (KChar 'N') _) = (createListStart =<<) . store-event (EvKey (KChar 'E') _) = (editListStart =<<) . store-event (EvKey (KChar 'X') _) = (write =<<) . (deleteCurrentList =<<) . store--- navigation-event (EvKey (KChar 'k') _) = previous-event (EvKey (KChar 'j') _) = next-event (EvKey (KChar 'h') _) = left-event (EvKey (KChar 'l') _) = right-event (EvKey (KChar 'G') _) = bottom--- moving items-event (EvKey (KChar 'K') _) = (write =<<) . (up =<<) . store-event (EvKey (KChar 'J') _) = (write =<<) . (down =<<) . store-event (EvKey (KChar 'H') _) = (write =<<) . (bottom =<<) . (left =<<) . (moveLeft =<<) . store-event (EvKey (KChar 'L') _) = (write =<<) . (bottom =<<) . (right =<<) . (moveRight =<<) . store-event (EvKey (KChar ' ') _) = (write =<<) . (moveRight =<<) . store-event (EvKey (KChar 'm') _) = showMoveTo--- removing items-event (EvKey (KChar 'D') _) = (write =<<) . (delete =<<) . store--- undo-event (EvKey (KChar 'u') _) = (write =<<) . undo--- moving lists-event (EvKey (KChar '>') _) = (write =<<) . (listRight =<<) . store-event (EvKey (KChar '<') _) = (write =<<) . (listLeft =<<) . store--- search-event (EvKey (KChar '/') _) = searchMode--- help-event (EvKey (KChar '?') _) = showHelp--- subtasks-event (EvKey KEnter _) = showDetail-event (EvKey (KChar '@') _) = (editDue =<<) . (store =<<) . showDetail -- selecting lists event (EvKey (KChar n) _) | isDigit n = selectList n
src/IO/Config.hs view
@@ -1,11 +1,13 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-} module IO.Config where import ClassyPrelude +import Data.Either (fromRight) import qualified Data.Text.IO as T (readFile) import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getHomeDirectory)@@ -16,7 +18,9 @@ import Data.FileEmbed (embedFile) import Data.Ini.Config -import UI.Theme (defaultTheme)+import IO.Keyboard.Parser (bindings)+import IO.Keyboard.Types (Bindings)+import UI.Theme (defaultTheme) import qualified IO.Config.General as General import qualified IO.Config.GitHub as GitHub@@ -48,44 +52,39 @@ legacyConfigPath = (</> "." <> directoryName) <$> getHomeDirectory xdgDefaultConfig :: IO FilePath-xdgDefaultConfig = (</> ".config" </> directoryName) <$> getHomeDirectory+xdgDefaultConfig = (</> ".config") <$> getHomeDirectory xdgConfigPath :: IO FilePath-xdgConfigPath = fromMaybe <$> xdgDefaultConfig <*> lookupEnv "XDG_CONFIG_HOME"+xdgConfigPath =+ (</> directoryName) <$> (fromMaybe <$> xdgDefaultConfig <*> lookupEnv "XDG_CONFIG_HOME") getDir :: IO FilePath getDir = legacyConfigPath >>= doesDirectoryExist >>= bool xdgConfigPath legacyConfigPath -getThemePath :: IO FilePath-getThemePath = (<> "/theme.ini") <$> getDir+themePath :: FilePath -> FilePath+themePath = (</> "theme.ini") -getConfigPath :: IO FilePath-getConfigPath = (<> "/config.ini") <$> getDir+configPath :: FilePath -> FilePath+configPath = (</> "config.ini") +bindingsPath :: FilePath -> FilePath+bindingsPath = (</> "bindings.ini")+ setup :: IO Config-setup = do- getDir >>= createDirectoryIfMissing True- createConfig- createTheme+setup+ -- create config dir+ = do+ dir <- getDir+ createDirectoryIfMissing True dir+ -- create config files+ create (configPath dir) $(embedFile "templates/config.ini")+ create (themePath dir) $(embedFile "templates/theme.ini")+ create (bindingsPath dir) $(embedFile "templates/bindings.ini")+ -- get config getConfig -create :: IO FilePath -> (FilePath -> IO ()) -> IO ()-create getPath write = do- path <- getPath- exists <- doesFileExist path- unless exists $ write path--writeTheme :: FilePath -> IO ()-writeTheme path = writeFile path $(embedFile "templates/theme.ini")--createTheme :: IO ()-createTheme = create getThemePath writeTheme--writeConfig :: FilePath -> IO ()-writeConfig path = writeFile path $(embedFile "templates/config.ini")--createConfig :: IO ()-createConfig = create getConfigPath writeConfig+create :: FilePath -> ByteString -> IO ()+create path contents = doesFileExist path >>= flip unless (writeFile path contents) configParser :: IniParser Config configParser =@@ -94,15 +93,19 @@ getConfig :: IO Config getConfig = do- content <- getConfigPath >>= T.readFile+ content <- T.readFile =<< (configPath <$> getDir) case parseIniFile content configParser of Right config -> pure config- Left s -> putStrLn (pack $ "config.ini: " <> s) *> pure defaultConfig+ Left s -> putStrLn (pack $ "config.ini: " <> s) $> defaultConfig +getBindings :: IO Bindings+getBindings = fromRight [] . bindings <$> (T.readFile =<< (bindingsPath <$> getDir))+ -- generate theme generateAttrMap :: IO AttrMap generateAttrMap = do- customizedTheme <- flip loadCustomizations defaultTheme =<< getThemePath+ dir <- getDir+ customizedTheme <- loadCustomizations (themePath dir) defaultTheme case customizedTheme of Right theme -> pure $ themeToAttrMap theme Left s -> putStrLn (pack $ "theme.ini: " <> s) $> themeToAttrMap defaultTheme
src/IO/HTTP/GitHub.hs view
@@ -96,9 +96,7 @@ pure $ columnToList column <$> cards addCards :: [Column] -> ReaderGitHubToken (Either Text Lists)-addCards columns = do- cols <- sequence (addCard <$> columns)- pure $ fromList <$> sequence cols+addCards columns = (fromList <$>) . sequence <$> traverse addCard columns getColumns :: Text -> ReaderGitHubToken (Either Text Lists) getColumns url = do
src/IO/HTTP/Trello.hs view
@@ -82,13 +82,13 @@ updateCard :: Card -> ReaderTrelloToken (Either Text Card) updateCard card = (setChecklists card . concat <$>) . sequence <$> checklists where- checklists = sequence $ getChecklist <$> (card ^. idChecklists)+ checklists = traverse getChecklist (card ^. idChecklists) updateList :: List -> ReaderTrelloToken (Either Text List)-updateList l = (setCards l <$>) . sequence <$> sequence (updateCard <$> (l ^. cards))+updateList l = (setCards l <$>) . sequence <$> traverse updateCard (l ^. cards) getChecklists :: [List] -> ReaderTrelloToken (Either Text [List])-getChecklists ls = sequence <$> sequence (updateList <$> ls)+getChecklists ls = sequence <$> traverse updateList ls getLists :: TrelloBoardID -> ReaderTrelloToken (Either Text Lists) getLists board = do@@ -102,7 +102,6 @@ Right raw -> fmap (trelloListsToLists timezone) <$> getChecklists raw Left err -> pure . Left $ parseError err 404 ->- pure . Left $- "Could not find Trello board " <> board <> ". Make sure the ID is correct"+ pure . Left $ "Could not find Trello board " <> board <> ". Make sure the ID is correct" 401 -> pure . Left $ "You do not have permission to view Trello board " <> board _ -> pure . Left $ tshow status <> " error. Cannot fetch from Trello."
+ src/IO/Keyboard.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE NoImplicitPrelude #-}++module IO.Keyboard+ ( generate+ ) where++import ClassyPrelude++import Data.Bitraversable (bitraverse)++import IO.Keyboard.Types++generate :: Bindings -> Actions -> BoundActions+generate bindings actions =+ mapFromList . catMaybes $ bitraverse bindingToEvent (`lookup` actions) <$> bindings
+ src/IO/Keyboard/Parser.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++module IO.Keyboard.Parser where++import ClassyPrelude++import Data.Attoparsec.Text++import IO.Keyboard.Types++-- utility functions+lexeme :: Parser a -> Parser a+lexeme p = skipSpace *> p <* skipSpace++commentP :: Parser ()+commentP = lexeme $ skipMany (char '#' *> manyTill anyChar endOfLine)++stripComments :: Parser a -> Parser a+stripComments p = lexeme $ commentP *> p <* commentP++word :: Parser Text+word = lexeme $ pack <$> many1 letter++-- ini parser+keyP :: Parser Binding+keyP = lexeme $ BKey <$> (char '<' *> word <* char '>')++charP :: Parser Binding+charP = lexeme $ BChar <$> anyChar++bindingP :: Parser [Binding]+bindingP = lexeme $ (keyP <|> charP) `sepBy` char ','++line :: Parser [(Binding, Text)]+line =+ stripComments $ do+ name <- word+ _ <- lexeme $ char '='+ binds <- bindingP+ pure $ (, name) <$> binds++bindingsP :: Parser Bindings+bindingsP = stripComments $ concat <$> many' line++-- run parser+bindings :: Text -> Either Text Bindings+bindings ini = first (const "Could not parse keyboard bindings.") (parseOnly bindingsP ini)
+ src/IO/Keyboard/Types.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++module IO.Keyboard.Types where++import ClassyPrelude++import Data.Map.Strict (Map)+import Graphics.Vty.Input.Events (Event (..), Key (..))++import Events.State.Types (Stateful)++data Binding+ = BChar Char+ | BKey Text+ deriving (Eq, Ord, Show)++type Bindings = [(Binding, Text)]++type Actions = Map Text Stateful++type BoundActions = Map Event Stateful++bindingToText :: Binding -> Text+bindingToText (BChar c) = singleton c+bindingToText (BKey name) = "<" <> name <> ">"++bindingsToText :: Bindings -> Text -> [Text]+bindingsToText bindings key = bindingToText . fst <$> toList (filterMap (== key) bindings)++bindingToEvent :: Binding -> Maybe Event+bindingToEvent (BChar char) = pure $ EvKey (KChar char) []+bindingToEvent (BKey "Space") = pure $ EvKey (KChar ' ') []+bindingToEvent (BKey "Backspace") = pure $ EvKey KBS []+bindingToEvent (BKey "Enter") = pure $ EvKey KEnter []+bindingToEvent (BKey "Left") = pure $ EvKey KLeft []+bindingToEvent (BKey "Right") = pure $ EvKey KRight []+bindingToEvent (BKey "Up") = pure $ EvKey KUp []+bindingToEvent (BKey "Down") = pure $ EvKey KDown []+bindingToEvent _ = Nothing
src/UI/Draw.hs view
@@ -26,10 +26,11 @@ 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.Modal (showModal) import UI.Theme-import UI.Types (ResourceName (..))+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@@ -79,7 +80,7 @@ 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, taskIndex)+ name = RNTask (ListIndex listIndex, TaskIndex taskIndex) widget = textField text widget' = widgetFromMaybe widget taskField pure $@@ -197,9 +198,10 @@ moveTo _ = False -- draw-draw :: Config -> Day -> State -> [Widget ResourceName]-draw layout today state =+draw :: Config -> Bindings -> Day -> State -> [Widget ResourceName]+draw layout bindings today state = showModal+ bindings normalisedState today [ runReader
src/UI/Modal.hs view
@@ -15,6 +15,7 @@ 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)@@ -31,10 +32,10 @@ where t = padBottom (Pad 1) . withAttr titleAttr $ textField title -showModal :: State -> Day -> [Widget ResourceName] -> [Widget ResourceName]-showModal state today view =+showModal :: Bindings -> State -> Day -> [Widget ResourceName] -> [Widget ResourceName]+showModal bindings state today view = case state ^. mode of- Modal Help -> surround help : view+ Modal Help -> surround (help bindings) : view Modal Detail {} -> surround (detail state today) : view Modal MoveTo -> surround (moveTo state) : view _ -> view
src/UI/Modal/Help.hs view
@@ -9,23 +9,53 @@ import ClassyPrelude import Brick-import Data.FileEmbed (embedFile)-import Data.Text as T (breakOn, justifyRight, replace, strip)+import Data.Text as T (justifyRight) +import IO.Keyboard.Types (Bindings, bindingsToText)+ import UI.Field (textField) import UI.Theme (taskCurrentAttr) import UI.Types (ResourceName) +descriptions :: [([Text], 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")+ ]++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 . T.strip . drop 1 $ r+ right = textField r -help :: (Text, Widget ResourceName)-help = ("Controls", w)+help :: Bindings -> (Text, Widget ResourceName)+help bindings = ("Controls", w) where- ls = lines $ decodeUtf8 $(embedFile "templates/controls.md")- (l, r) = unzip $ breakOn ":" . T.replace "`" "" . T.strip . drop 1 <$> ls- m = foldl' max 0 $ length <$> l- w = vBox $ line m <$> zip l r+ ls = format <$> generate bindings+ m = foldl' max 0 $ length . fst <$> ls+ w = vBox $ line m <$> ls
src/UI/Types.hs view
@@ -4,9 +4,17 @@ import ClassyPrelude (Eq, Int, Ord, Show) +newtype ListIndex = ListIndex+ { showListIndex :: Int+ } deriving (Show, Eq, Ord)++newtype TaskIndex = TaskIndex+ { showTaskIndex :: Int+ } deriving (Show, Eq, Ord)+ data ResourceName = RNCursor- | RNTask (Int, Int)+ | RNTask (ListIndex, TaskIndex) | RNList Int | RNLists | RNModal
taskell.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.12 name: taskell-version: 1.3.6.0+version: 1.4.0.0 license: BSD3 license-file: LICENSE copyright: 2019 Mark Wales@@ -16,8 +16,8 @@ extra-source-files: README.md templates/api-error.txt+ templates/bindings.ini templates/config.ini- templates/controls.md templates/github-token.txt templates/theme.ini templates/trello-token.txt@@ -50,6 +50,9 @@ IO.HTTP.GitHub IO.HTTP.Trello.List IO.HTTP.Trello.ChecklistItem+ IO.Keyboard+ IO.Keyboard.Parser+ IO.Keyboard.Types UI.Field hs-source-dirs: src other-modules:@@ -87,25 +90,26 @@ default-language: Haskell2010 default-extensions: OverloadedStrings NoImplicitPrelude build-depends:- aeson >=1.3.1.1 && <1.4,- base >=4.11.1.0 && <=5,- brick >=0.37.2 && <0.38,+ aeson >=1.4.2.0 && <1.5,+ attoparsec >=0.13.2.2 && <0.14,+ base >=4.12.0.0 && <=5,+ brick ==0.47.*, bytestring >=0.10.8.2 && <0.11,- classy-prelude >=1.4.0 && <1.5,- config-ini >=0.2.2.0 && <0.3,- containers >=0.5.11.0 && <0.6,- directory >=1.3.1.5 && <1.4,- file-embed >=0.0.10.1 && <0.1,+ classy-prelude >=1.5.0 && <1.6,+ config-ini >=0.2.4.0 && <0.3,+ 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.2 && <2.4,- http-types >=0.12.2 && <0.13,- lens >=4.16.1 && <4.17,+ http-conduit >=2.3.6.1 && <2.4,+ http-types >=0.12.3 && <0.13,+ lens ==4.17.*, mtl >=2.2.2 && <2.3,- template-haskell >=2.13.0.0 && <2.14,+ template-haskell >=2.14.0.0 && <2.15, text >=1.2.3.1 && <1.3, time >=1.8.0.2 && <1.9,- vty ==5.21.*+ vty >=5.25.1 && <5.26 executable taskell main-is: Main.hs@@ -116,8 +120,8 @@ default-extensions: OverloadedStrings NoImplicitPrelude ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends:- base >=4.11.1.0 && <4.12,- classy-prelude >=1.4.0 && <1.5,+ base >=4.12.0.0 && <4.13,+ classy-prelude >=1.5.0 && <1.6, taskell -any test-suite taskell-test@@ -133,6 +137,8 @@ Data.Taskell.TaskTest Events.StateTest IO.GitHubTest+ IO.Keyboard.ParserTest+ IO.KeyboardTest IO.MarkdownTest IO.TrelloTest UI.FieldTest@@ -141,16 +147,18 @@ default-extensions: OverloadedStrings NoImplicitPrelude ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends:- aeson >=1.3.1.1 && <1.4,- base >=4.11.1.0 && <4.12,- classy-prelude >=1.4.0 && <1.5,- containers >=0.5.11.0 && <0.6,- file-embed >=0.0.10.1 && <0.1,- lens >=4.16.1 && <4.17,+ aeson >=1.4.2.0 && <1.5,+ base >=4.12.0.0 && <4.13,+ classy-prelude >=1.5.0 && <1.6,+ containers >=0.6.0.1 && <0.7,+ file-embed >=0.0.11 && <0.1,+ lens ==4.17.*,+ raw-strings-qq ==1.1.*, taskell -any,- tasty >=1.1.0.4 && <1.2,+ tasty ==1.2.*, tasty-discover >=4.2.1 && <4.3, tasty-expected-failure >=0.11.1.1 && <0.12, tasty-hunit >=0.10.0.1 && <0.11, text >=1.2.3.1 && <1.3,- time >=1.8.0.2 && <1.9+ time >=1.8.0.2 && <1.9,+ vty >=5.25.1 && <5.26
+ templates/bindings.ini view
@@ -0,0 +1,38 @@+# 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 = <
− templates/controls.md
@@ -1,23 +0,0 @@-- `?`: Show this list of controls-- `j` / `k` / `h` / `l`: Move down/up/left/right-- `G`: Go to bottom of list-- `1`-`9`: Select list-- `a`: Add a task-- `O` / `o`: Add a task above/below-- `e`, `i`, `A`: Edit a task-- `C`: Change task-- `Enter`: Show task details / Edit task description-- `@`: Add/edit due date (yyyy-mm-dd)-- `J` / `K`: Shift task down/up-- `H` / `L`: Shift task left/right-- `Space`: Shift task right-- `m`: Move task to specific list-- `D`: Delete task-- `u`: Undo-- `N`: New list-- `E`: Edit list title-- `X`: Delete list-- `<` / `>`: Move list left/right-- `/`: Search-- `Esc`: Return to lists-- `q`: Quit
+ test/IO/Keyboard/ParserTest.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}++module IO.Keyboard.ParserTest+ ( test_parser+ ) where++import ClassyPrelude++import Test.Tasty+import Test.Tasty.HUnit++import Data.FileEmbed (embedFile)+import Text.RawString.QQ (r)++import IO.Keyboard.Parser (bindings)+import IO.Keyboard.Types++basic :: Text+basic = "quit = q"++basicResult :: Bindings+basicResult = [(BChar 'q', "quit")]++basicMulti :: Text+basicMulti =+ [r|+ quit = q+ detail = <Enter>+ |]++basicMultiResult :: Bindings+basicMultiResult = [(BChar 'q', "quit"), (BKey "Enter", "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")+ ]++comma :: Text+comma = "quit = ,"++commaResult :: Bindings+commaResult = [(BChar ',', "quit")]++test_parser :: TestTree+test_parser =+ testGroup+ "IO.Keyboard.Parser"+ [ testCase "basic" (assertEqual "Parses quit" (Right basicResult) (bindings basic))+ , testCase+ "basic multiline"+ (assertEqual "Parses both" (Right basicMultiResult) (bindings basicMulti))+ , testCase "full ini file" (assertEqual "Parses all" (Right iniResult) (bindings ini))+ , testCase "comma" (assertEqual "Parses comma" (Right commaResult) (bindings comma))+ ]
+ test/IO/KeyboardTest.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-}++module IO.KeyboardTest+ ( test_keyboard+ ) where++import ClassyPrelude++import Test.Tasty+import Test.Tasty.HUnit++import Control.Lens ((.~))++import Data.Taskell.Lists.Internal (initial)+import Events.State (create, quit)+import Events.State.Types (State, Stateful, mode)+import Events.State.Types.Mode (Mode (Shutdown))+import Graphics.Vty.Input.Events (Event (..), Key (..))+import IO.Keyboard (generate)+import IO.Keyboard.Types++tester :: BoundActions -> Event -> Stateful+tester actions ev state = lookup ev actions >>= ($ state)++cleanState :: State+cleanState = create "taskell.md" initial++basicBindings :: Bindings+basicBindings = [(BChar 'q', "quit")]++basicActions :: Actions+basicActions = [("quit", quit)]++basicResult :: Maybe State+basicResult = Just $ (mode .~ Shutdown) cleanState++test_keyboard :: TestTree+test_keyboard =+ testGroup+ "IO.Keyboard"+ [ testCase+ "generate"+ (assertEqual+ "Parses basic"+ basicResult+ (tester (generate basicBindings basicActions) (EvKey (KChar 'q') []) cleanState))+ ]